C     DEBOER-WINTHER MULTIPLE COULOMB EXCITATION PROGRAM                00010000
C                                                                       00020000
C     ADMINISTRATION PROGRAM                                            00030000
C     PROGRAM COULOMB(DAT,OUTPUT,TAPE5=DAT,TAPE6=OUTPUT,DEBUG=OUTPUT)   00040000
C                                                                       00050000
C*********************************************************************  00060000
C                                                                    *  00070000
C    INFORMATION ABOUT THE DIMENSIONS IN THE PROGRAM                 *  00080000
C    MAXIMUM NUMBER OF ELEMENTS IN ZETA ARRAY    = NZMAX             *  00090000
C    MAXIMUM NUMBER OF MAGNETIC SUBSTATES        = ICATMX            *  00100000
C    MAXIMUM NUMBER OF NUCLEAR LEVELS            = NDIM              *  00110000
C    NZMAX = 20000,   ICATMX = 350,   NDIM = 30                      *  00120000
C                                                                    *  00130000
C    E1-POLARISATION IS POSSIBLE      H.J.WOLLERSHEIM GSI 20.6.79    *  00140000
C*********************************************************************  00150000
      COMMON/LARGE/ZETA(20000),NZMAX                                    00160000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       00170000
     1SSTART(31),SSTOP(30)                                              00180000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  00190000
      INTEGER OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5                 00200000
      COMMON/ART/OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5              00210000
      COMMON/ALL/NMAX,NDIM,NCORR                                        00220000
      COMMON/P1IT/ CAT(350,3),ICATMX, ISMAX                             00230000
      COMMON/EMR/QZERO,ALPHA0,ALPHA2,QUINT2,QUINT4,QUINT6               00240000
      COMMON/ARI/NTIME                                                  00250000
      COMMON/AR/NANGLE,THI,TLI                                          00260000
      COMMON/ARS/SIMP                                                   00270000
      LOGICAL ERR                                                       00280000
      COMMON/EROR/ERR                                                   00290000
      COMMON/FCT10/FCT(100)                                             00300000
      COMMON/RI/OUAMP,OUPROW,INTERV,INTIN                               00310000
      INTEGER OUAMP,OUPROW                                              00320000
      INTEGER OUXI,OUPSI                                                00330000
      COMMON/RP/OUXI,OUPSI,NCM,EMMAX1                                   00340000
      REAL ME                                                           00350000
      COMMON/RP1M/ME(30,30,12)                                          00360000
      COMMON/RPIS/XIMAX                                                 00370000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          00380000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   00390000
      COMMON/RPST/THETA                                                 00400000
      COMMON/RS/NMAXIN,SIGTOT(30),ACCIN,PIN(30),VA,DVA,VALO,VAUP        00410000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       00420000
      COMMON/RDSTA/IPAR(30),IFAC(30)                                    00430000
      COMMON/GAM/TGAMMA,PGAMMA                                          00440000
      COMMON/EUL/ALPHA,BETA,GAMMA,THETAC,PHIC                           00450000
      COMMON/MR/IPURG                                                   00460000
      COMMON/MRCH/IA17,IA18,IA19                                        00470000
      COMMON/BLOCK1/MAGEXC                                              00480000
      COMMON/HJW/IPRINT
C                                                                       00490000
C        INTERPRETATION OF INPUT CARDS.                                 00500000
C        INPUT IS FLOATING POINT FORMAT (8F10.5). SUPPLY DECIMAL POINT I00510000
C        ALL INPUT QUANTITIES.                                          00520000
C                                                                       00530000
C        COLUMNS ON DATA CARDS                                          00540000
C         1-10  11-20  21-30  31-40  41-50  51-60  61-70  71-80         00550000
C                                                                       00560000
C         1     NMAX                                                    00570000
C         2     NCM                                                     00580000
C         3     NTIME                                                   00590000
C         4     XIMAX                                                   00600000
C         5     EMMAX1                                                  00610000
C         6     ACCUR,QPAR                                              00620000
C         7     OUXI                                                    00630000
C         8     OUPSI                                                   00640000
C         9     OUAMP                                                   00650000
C         10    OUPROW                                                  00660000
C         11    OUANG0                                                  00670000
C         12    OUANG1                                                  00680000
C         13    OUANG2                                                  00690000
C         14    OUANG3                                                  00700000
C         15    NCORR                                                   00710000
C         16    INTERV                                                  00720000
C         17    Z1      A1                                              00730000
C         18    Z2     A2                                               00740000
C         19    EP                                                      00750000
C         20    TLBDG                                                   00760000
C         21    THETA                                                   00770000
C         22     N      SPIN(N) EN(N) IPAR(N)                           00780000
C         23     N      M   ME(N,M,LA)   LA                             00790000
C        IF LA=MULTIPOLARITY IS ENTERED AS 0 LA=2 IS SUBSTITUTED        00800000
C        LET M GO FROM 1 TO NMAX AND LET N GO FROM M TO NMAX, REST OF   00810000
C        MATRIX WILL BE SYMMETRIZED BY PROGRAM                          00820000
C         24     N      M   MM(N,M,LA)   LA                             00830000
C         25     QZERO  ALPHA0 ALPHA2 QUINT2  QUINT4  QUINT6            00840000
C         33    NGMAX                                                   00850000
C         34    I      NSTART(I) NSTOP(I)   EMMAX(I)                    00860000
C         35    I1     I2        MISTER(I1,I2)                          00870000
C        LET I1 GO FROM 1 TO NGMAX AND LET I2 GO FROM I1 TO NGMAX. REST 00880000
C        MISTER - MATRIX WILL BE SYMMETRIZED BY PROGRAM.                00890000
C         36    I      IEXCIT(I)                                        00900000
C         37    THETAC,PHIC                                             00910000
C         38    TGAMMA,PGAMMA                                           00920000
C                                                                       00930000
C        UNLESS OTHERWISE SPECIFIED, THE FOLLOWING VALUES OF INPUTS WILL00940000
C        BE ASSUMED:                                                    00950000
C                                                                       00960000
      IPRINT=0
 500  NMAX = 2                                                          00970000
      NGMAX = 1                                                         00980000
      NMAXIN = NMAX                                                     00990000
      NCM = 2                                                           01000000
      NCORR = 0                                                         01010000
      NTIME = 1000                                                      01020000
      INTERV = 1                                                        01030000
      INTIN = INTERV                                                    01040000
      XIMAX = 6.                                                        01050000
      EMMAX1 = 50.0                                                     01060000
      ACCUR = .0001                                                     01070000
      ACCIN=.0001                                                       01080000
      QPAR = 0.005                                                      01090000
      OUXI = 1                                                          01100000
      OUPSI = 0                                                         01110000
      OUAMP = 0                                                         01120000
      OUPROW = 0                                                        01130000
      OUANG0 = 0                                                        01140000
      OUANG1 = 0                                                        01150000
      OUANG2 = 0                                                        01160000
      OUANG3 = 0                                                        01170000
      OUANG4 = 0                                                        01180000
      OUANG5 = 0                                                        01190000
      ILEAD=1                                                           01200000
      TLI=0.0                                                           01210000
      THI=0.0                                                           01220000
C                                                                       01230000
      NZMAX = 20000                                                     01240000
      ICATMX = 350                                                      01250000
      NDIM = 30                                                         01260000
      MAGEXC = 0                                                        01270000
      DO 60 I=1,10                                                      01280000
      EMMAX(I) = 50.0                                                   01290000
      IEXCIT(I) = 2                                                     01300000
      NSTART(I) = 0                                                     01310000
      NSTOP(I) = 0                                                      01320000
      DO 70 J=1,10                                                      01330000
      MISTER(I,J) = 1                                                   01340000
  70  CONTINUE                                                          01350000
  60  CONTINUE                                                          01360000
      LAMMAX = 0                                                        01370000
      DO 15 LAM = 1,12                                                  01380000
  15  LAMDA(LAM) = 1000                                                 01390000
      DO 2351 I=1,NDIM                                                  01400000
      EN(I) = 0.0                                                       01410000
      SPIN(I) = 0.0                                                     01420000
      IPAR(I) = 1                                                       01430000
      DO 2352 J=1,NDIM                                                  01440000
      DO 85 LAM=1,12                                                    01450000
      ME(I,J,LAM)=0.0                                                   01460000
  85  CONTINUE                                                          01470000
2352  CONTINUE                                                          01480000
2351  CONTINUE                                                          01490000
      Z1 = 0.                                                           01500000
      Z2 = 0.                                                           01510000
      A1 = 0.                                                           01520000
      A2 = 0.                                                           01530000
      EP = 0.                                                           01540000
      QZERO = 0.                                                        01550000
      ALPHA0 = 0.                                                       01560000
      ALPHA2 = 0.                                                       01570000
      QUINT2 = 0.                                                       01580000
      QUINT4 = 0.                                                       01590000
      QUINT6 = 0.                                                       01600000
      THETAC = 0.                                                       01610000
      PHIC = 0.                                                         01620000
      TGAMMA = 0.                                                       01630000
      PGAMMA = 0.                                                       01640000
      IA17 = 0                                                          01650000
      IA18 = 0                                                          01660000
      IA19 = 0                                                          01670000
C     ONLY TO INITIALIZE FACTORIAL ARRAY FCT                            01680000
      FCT(1)=1.0                                                        01690000
      DO 101 I=1,99                                                     01700000
 101  FCT(I+1)=FLOAT(I)/10.0*FCT(I)                                     01710000
C     INITIALIZE THE LOGICAL VARIABLE ERR                               01720000
      ERR = .FALSE.                                                     01730000
      GO TO 1                                                           01740000
1111  CONTINUE                                                          01750000
      ERR=.FALSE.                                                       01760000
      GOTO 1                                                            01770000
   8  CONTINUE                                                          01780000
   1  IPURG = 0                                                         01790000
      CALL READER                                                       01800000
      IF(IPURG.EQ.1)GOTO 500                                            01810000
C                                                                       01820000
      IF(ERR) GO TO 1111                                                01830000
      ASSIGN 4 TO ITT                                                   01840000
      IF(NANGLE.GT.1) ASSIGN 5 TO ITT                                   01850000
      CALL PR1                                                          01860000
      IF(ERR) GO TO 1111                                                01870000
   3  CALL PR2                                                          01880000
      IF(ERR) GO TO 1111                                                01890000
      CALL INTG                                                         01900000
      IF(ERR) GO TO 1111                                                01910000
      IF(OUANG0.NE.0.OR.OUANG1.NE.0.OR.OUANG2.NE.0.OR.OUANG3.NE.0.OR.   01920000
     1OUANG4.NE.0) CALL TENS                                            01930000
      IF(ERR) GO TO 1111                                                01940000
  42  CALL SIGM                                                         01950000
      IF(ERR) GOTO 1111                                                 01960000
      GO TO ITT, (4,5)                                                  01970000
   5  CONTINUE                                                          01980000
      ASSIGN 4 TO ITT                                                   01990000
   4  IF(NMAX.EQ.1) GO TO 8                                             02000000
      IF(SIMP.NE.0.0) GO TO 3                                           02010000
      GO TO 8                                                           02020000
      END                                                               02030000
      SUBROUTINE AMPDER(AMP,AMPDOT,K)                                   02040000
C                                                                       02050000
C     THIS ROUTINE DECIDES FOR WHICH IR AMPDOT(IR,L) IS CALCULATED      02060000
C                                                                       02070000
      COMPLEX AMP,AMPDOT,RC                                             02080000
      INTEGER SSTART,SSTOP                                              02090000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       02100000
     1SSTART(31),SSTOP(30)                                              02110000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          02120000
      COMMON /P1IT/ CAT(350,3),ICATMX, ISMAX                            02130000
      COMMON/IPREP/LMX,IR1,IR2,N1,N2                                    02140000
      COMMON/AMPLAI/NZ                                                  02150000
      DIMENSION AMP(350,4),AMPDOT(350,4)                                02160000
C                                                                       02170000
      IF(K.EQ.2)GOTO 700                                                02180000
      NZ = 0                                                            02190000
 700  IF(SPIN(N1).EQ.0.)GOTO 710                                        02200000
C     IR - LOOP FOR GROUND STATE SPIN .NE.0                             02210000
      DO 720 IR=IR1,IR2                                                 02220000
      N = CAT(IR,1)                                                     02230000
      CALL LAISUM(AMP,AMPDOT,IR,N,LMX)                                  02240000
 720  CONTINUE                                                          02250000
      RETURN                                                            02260000
C     IR - LOOP FOR GROUND STATE SPIN .EQ.0                             02270000
 710  DO 730 N=N1,N2                                                    02280000
      IR = SSTART(N) - 1                                                02290000
 731  IR = IR + 1                                                       02300000
      CALL LAISUM(AMP,AMPDOT,IR,N,LMX)                                  02310000
      IF(CAT(IR,3).LT.-0.1)GOTO 731                                     02320000
 730  CONTINUE                                                          02330000
      RETURN                                                            02340000
      END                                                               02350000
      SUBROUTINE CHECK                                                  02360000
C                                                                       02370000
C     THIS ROUTINE CHECKS THE INPUT DATA                                02380000
C                                                                       02390000
      LOGICAL ERR                                                       02400000
      COMMON/EROR/ERR                                                   02410000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  02420000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          02430000
      COMMON/ALL/NMAX,NDIM,NCORR                                        02440000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       02450000
      COMMON/MRCH/IA17,IA18,IA19                                        02460000
C                                                                       02470000
C     CONTROL WHETHER PROJECTILE GROUPS AND TARGET GROUPS ARE SEPARATED 02480000
      J = IEXCIT(1)                                                     02490000
      IEXNUM = 1                                                        02500000
      DO 100 I=1,NGMAX                                                  02510000
      IF(IEXCIT(I).EQ.J)GOTO 100                                        02520000
      IP = I                                                            02530000
      IEXNUM = IEXNUM + 1                                               02540000
      J = IEXCIT(I)                                                     02550000
 100  CONTINUE                                                          02560000
      IF(IEXNUM.LE.2)GOTO 120                                           02570000
      ERR = .TRUE.                                                      02580000
      WRITE(66,900)                                                     02590000
      RETURN                                                            02600000
C     CHECK OF GROUND STATE SPIN, GROUND STATE ENERGY AND EMMAX         02610000
 120  DO 140 K=1,IEXNUM                                                 02620000
      J = 1                                                             02630000
      IF(K.EQ.2) J=NSTART(IP)                                           02640000
      IF(SPIN(J).LE.3.5)GOTO 125                                        02650000
      ERR = .TRUE.                                                      02660000
      WRITE(66,902) J,SPIN(J)                                           02670000
 125  IF(EN(J).EQ.0.)GOTO 130                                           02680000
      ERR = .TRUE.                                                      02690000
      WRITE(66,904) J,EN(J)                                             02700000
 130  DO 139 I=1,NGMAX                                                  02710000
      NGRD = 1                                                          02720000
      IF(IEXNUM.EQ.2.AND.I.GE.IP) NGRD=NSTART(IP)                       02730000
      IF(EMMAX(I).GE.SPIN(NGRD))GOTO 139                                02740000
      ERR = .TRUE.                                                      02750000
      WRITE(66,906) I,EMMAX(I)                                          02760000
 139  CONTINUE                                                          02770000
 140  CONTINUE                                                          02780000
C     CHECK OF NSTART- AND NSTOP-ARRAY                                  02790000
      IF(NGMAX.EQ.1)GOTO 165                                            02800000
      DO 160 I=2,NGMAX                                                  02810000
      J = I-1                                                           02820000
      IF(NSTART(I)-NSTOP(J).EQ.1)GOTO 160                               02830000
      ERR = .TRUE.                                                      02840000
      WRITE(66,908) J,NSTOP(J),I,NSTART(I)                              02850000
 160  CONTINUE                                                          02860000
C     CHECK OF NCM AND NMAX                                             02870000
 165  IF(NGMAX.LE.NMAX)GOTO 170                                         02880000
      ERR = .TRUE.                                                      02890000
      WRITE(66,910) NMAX,NGMAX                                          02900000
 170  IF(NCM.LE.NMAX)GOTO 180                                           02910000
      WRITE(66,912) NMAX,NCM                                            02920000
      NCM = 2                                                           02930000
C     CONTROL WHETHER INPUT DATA CONTAIN EP,Z1,A1,Z2,A2                 02940000
 180  IF(IA17.EQ.1.AND.IA18.EQ.1.AND.IA19.EQ.1)GOTO 190                 02950000
      ERR = .TRUE.                                                      02960000
      WRITE(66,914)                                                     02970000
C     CONTROL WHTETHER ALL SPINS ARE INTEGER OR HALF INTEGER            02980000
 190  DO 220 K=1,IEXNUM                                                 02990000
      N1 = 1                                                            03000000
      N2 = NMAX                                                         03010000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   03020000
      IF(K.EQ.1)GOTO 195                                                03030000
      N1 = NSTART(IP)                                                   03040000
      N2 = NMAX                                                         03050000
 195  DO 210 N=N1,N2                                                    03060000
      S = SPIN(N)-SPIN(N1)                                              03070000
      J = S                                                             03080000
      DIFF = S - FLOAT(J)                                               03090000
      IF(DIFF.LT.0.01)GOTO 210                                          03100000
      ERR = .TRUE.                                                      03110000
      WRITE(66,916) N1,SPIN(N1),N,SPIN(N)                               03120000
 210  CONTINUE                                                          03130000
 220  CONTINUE                                                          03140000
      RETURN                                                            03150000
 900  FORMAT(50H ERROR  -  TARGET GROUPS AND PROJECTILE GROUPS ARE,     03160001
     114H NOT SEPARATED//21H EXECUTION TERMINATED)                      03170001
 902  FORMAT(6H SPIN(,I2,4H) = ,F4.1/                                   03180001
     147H ERROR  -  GROUND STATE SPIN MUST BE  .LT.  3.5)               03190001
 904  FORMAT(4H EN(,I2,4H) = ,F8.4,4H MEV/                              03200001
     149H ERROR  -  GROUND STATE ENERGY MUST BE  .EQ.  0.0)             03210001
 906  FORMAT(7H EMMAX(,I2,4H) = ,F4.1/                                  03220001
     149H ERROR  -  EMMAX MUST BE  .GE.  GROUND STATE SPIN)             03230001
 908  FORMAT(7H NSTOP(,I2,4H) = ,I2,3X,7HNSTART(,I2,4H) = ,I2/          03240001
     151H ERROR  -  NSTART(I+1) - NSTOP(I)  MUST BE  .EQ.  1)           03250001
 910  FORMAT(8H NMAX = ,I2,4X,8HNGMAX = ,I2/                            03260001
     136H ERROR  -  NGMAX MUST BE  .LE.  NMAX)                          03270001
 912  FORMAT(8H NMAX = ,I2,4X,6HNCM = ,I2/25H PROGRAM ASSUMES  NCM = 2) 03280001
 914  FORMAT(53H ERROR  -  SOME OF THE FOLLOWING INPUT QUANTITIES ARE,  03290001
     129H MISSING:  EP, Z1, A1, Z2, A2)                                 03300000
 916  FORMAT(6H SPIN(,I2,4H) = ,F4.1,4X,5HSPIN(,I2,4H) = ,F4.1/         03310001
     19H ERROR  -,                                                      03320001
     260H  FOR EACH NUCLEUS ALL SPINS MUST BE INTEGER OR HALF INTEGER)  03330001
      END                                                               03340000
      SUBROUTINE CMLAB(A1,A2,EP,EN,NMAX,TLBDG,TCMDG,ZLBDG,R3,R4,EPP,ETP)03350000
C                                                                       03360000
C     THIS ROUTINE TRANSFORMS FROM LAB-SYSTEM TO CM-SYSTEM              03370000
C                                                                       03380000
      LOGICAL ERR                                                       03390000
      COMMON/EROR/ERR                                                   03400000
      DIMENSION EN(30),R3(30),R4(30),EPP(30),ETP(30)                    03410000
      DIMENSION TCMDG(30),TCMRAD(30),ZLBDG(30),ZLBRAD(30)               03420000
C                                                                       03430000
      TLBRAD = TLBDG/57.2957795                                         03440000
      ARED = 1.0 + A1/A2                                                03450000
      EMAX = EP/ARED                                                    03460000
      DO 8 N=1,NMAX                                                     03470000
      IF (EN(N).LT.EMAX) GOTO 2                                         03480000
      WRITE(66,1) EMAX                                                  03490000
   1  FORMAT(37H ERROR- MAXIMUM EXCITATION ENERGY IS ,F8.4,4H MEV)      03500001
      GOTO 1111                                                         03510000
   2  EPMIN = EP - EN(N)*ARED                                           03520000
      TAUP = SQRT(EP/EPMIN)                                             03530000
      TAU = TAUP * A1/A2                                                03540000
      IF (TAU.LE.1.0) GOTO 6                                            03550000
CDC   TMXDG = ASIN(1.0/TAU) * 57.2957795                                03560000
      TMXDG = ASIN(1.0/TAU) * 57.2957795                                03570000
      IF (TMXDG.GE.TLBDG) GOTO 6                                        03580000
      WRITE(66,3) TMXDG                                                 03590000
   3  FORMAT(36H ERROR- MAXIMUM SCATTERING ANGLE IS ,F7.2,8H DEGREES)   03600001
      GOTO 1111                                                         03610000
CDC6  TCMRAD(N) = TLBRAD + ASIN(TAU*SIN(TLBRAD))                        03620000
   6  TCMRAD(N) = TLBRAD + ASIN(TAU*SIN(TLBRAD))                        03630000
      TCMDG(N) = TCMRAD(N)*57.2957795                                   03640000
      IF (TAU.LE.1.0) GOTO 12                                           03650000
      WRITE(66,5) TCMDG(N),N                                            03660000
   5  FORMAT(39H SECOND POSSIBLE CM SCATTERING ANGLE IS ,F7.2,          03670001
     117H DEGREES FOR N = ,I3)                                          03680001
      TCMDG(N) = 180.+2.*TLBDG-TCMDG(N)                                 03690000
      TCMRAD(N) = TCMDG(N)/57.2957795                                   03700000
  12  ZCMDG = 180.0 - TCMDG(N)                                          03710000
      ZCMRAD = ZCMDG/57.2957795                                         03720000
      ZLBRAD(N) = ATAN(SIN(ZCMRAD)/(COS(ZCMRAD)+TAUP))                  03730000
      ZLBDG(N) = ZLBRAD(N)*57.2957795                                   03740000
      IF(ABS(TCMDG(N)-180.).LT.1.E-10)GOTO 7                            03750000
      R3(N)=(SIN(TLBRAD)/SIN(TCMRAD(N)))**2*ABS(COS(TCMRAD(N)-TLBRAD))  03760000
      R4(N)=(SIN(ZLBRAD(N))/SIN(ZCMRAD))**2*ABS(COS(ZCMRAD-ZLBRAD(N)))  03770000
      GOTO 10                                                           03780000
   7  R3(N) = 1.0/(1.0-TAU)**2                                          03790000
      R4(N) = 1.0/(1.0+TAUP)**2                                         03800000
  10  R3(N) = 1.0/R3(N)                                                 03810000
      R4(N) = 1.0/R4(N)                                                 03820000
      EPP(N)=(A2/(A1+A2))**2*(1.0+TAU*TAU+2*TAU*COS(TCMRAD(N)))*EPMIN   03830000
      ETP(N)=A1*A2/(A1+A2)**2*(1.+TAUP*TAUP+2.*TAUP*COS(ZCMRAD))*EPMIN  03840000
   8  CONTINUE                                                          03850000
      RETURN                                                            03860000
1111  ERR = .TRUE.                                                      03870000
      RETURN                                                            03880000
      END                                                               03890000
      FUNCTION DJMM(BETA,RJ,RM,RMP)                                     03900000
C                                                                       03910000
C     THIS ROUTINE COMPUTES THE D-FUNCTION                              03920000
C                                                                       03930000
      COMMON/FCT10/FCT(100)                                             03940000
      J=2.001*RJ                                                        03950000
      M=2.001*RM                                                        03960000
      MP=2.001*RMP                                                      03970000
C     IF((J.LT.IABS(M)).OR.(J.LT.IABS(MP))) GO TO 2                     03980000
      B=BETA/57.295779                                                  03990000
      CB=COS(B/2.0)                                                     04000000
      SB=SIN(B/2.0)                                                     04010000
      JA=(J+MP)/2+1                                                     04020000
      JB=(J-MP)/2+1                                                     04030000
      JC=(J+M)/2+1                                                      04040000
      JD=(J-M)/2+1                                                      04050000
      ROOT=SQRT(FCT(JA)*FCT(JB)*FCT(JC)*FCT(JD))                        04060000
      MINSIG=0                                                          04070000
      IF(M+MP.LT.0) MINSIG=-M-MP                                        04080000
      MAXSIG=J-M                                                        04090000
      IF(M.LT.MP) MAXSIG=J-MP                                           04100000
      ISIG=MINSIG                                                       04110000
      DD=0.0                                                            04120000
   1  JA=ISIG/2+1                                                       04130000
      JB=(J-M-ISIG)/2+1                                                 04140000
      JC=(J-MP-ISIG)/2+1                                                04150000
      JD=(M+MP+ISIG)/2+1                                                04160000
      FASE=(-1.0)**((J-MP-ISIG)/2)                                      04170000
      IC=ISIG+(M+MP)/2                                                  04180000
      IS=J-ISIG-(M+MP)/2                                                04190000
      DD=DD+FASE/(FCT(JA)*FCT(JB)*FCT(JC)*FCT(JD))*CB**IC*SB**IS        04200000
      ISIG=ISIG+2                                                       04210000
      IF(ISIG.LE.MAXSIG) GO TO 1                                        04220000
      DJMM=ROOT*DD                                                      04230000
      RETURN                                                            04240000
C  2  WRITE(66,3)                                                       04250000
C  3  FORMAT(24H  ERROR IN DJMM-ARGUMENT)                               04260001
C     STOP                                                              04270000
      END                                                               04280000
      SUBROUTINE ERROR(I)                                               04290000
C                                                                       04300000
C     THIS ROUTINE PRINTS ERROR MESSAGES                                04310000
C                                                                       04320000
      LOGICAL ERR                                                       04330000
      COMMON/EROR/ERR                                                   04340000
      COMMON/ALL/NMAX,NDIM,NCORR                                        04350000
C                                                                       04360000
      ERR = .TRUE.                                                      04370000
      GOTO(101,102,103,104,105,106,107,108,109,110,111,112,113,114,     04380000
     1 115,116,117,118,119,120,121,122),I                               04390000
 101  WRITE(66,901) NDIM                                                04400000
      RETURN                                                            04410000
 102  WRITE(66,902)                                                     04420000
      RETURN                                                            04430000
 103  WRITE(66,903)                                                     04440000
      RETURN                                                            04450000
 104  WRITE(66,904)                                                     04460000
      RETURN                                                            04470000
 105  WRITE(66,905)                                                     04480000
      RETURN                                                            04490000
 106  WRITE(66,906)                                                     04500000
      RETURN                                                            04510000
 107  WRITE(66,907)                                                     04520000
      RETURN                                                            04530000
 108  WRITE(66,908)                                                     04540000
      RETURN                                                            04550000
 109  WRITE(66,909) NDIM                                                04560000
      RETURN                                                            04570000
 110  WRITE(66,910)                                                     04580000
      RETURN                                                            04590000
 111  WRITE(66,911)                                                     04600000
      RETURN                                                            04610000
 112  WRITE(66,912)                                                     04620000
      RETURN                                                            04630000
 113  WRITE(66,913)                                                     04640000
      RETURN                                                            04650000
 114  WRITE(66,914)                                                     04660000
      RETURN                                                            04670000
 115  WRITE(66,915)                                                     04680000
      RETURN                                                            04690000
 116  WRITE(66,916) NDIM                                                04700000
      RETURN                                                            04710000
 117  WRITE(66,917)                                                     04720000
      RETURN                                                            04730000
 118  WRITE(66,918)                                                     04740000
      RETURN                                                            04750000
 119  WRITE(66,919)                                                     04760000
      RETURN                                                            04770000
 120  WRITE(66,920)                                                     04780000
      RETURN                                                            04790000
 121  WRITE(66,921)                                                     04800000
      RETURN                                                            04810000
 122  WRITE(66,922)                                                     04820000
      RETURN                                                            04830000
 901  FORMAT(46H INPUT ERROR  --  NMAX MUST BE .GE. 2 AND .LT. ,I2/)    04840000
 902  FORMAT(54H INPUT ERROR  --  XIMAX MUST BE .GT. 0.0 AND .LT. 99.0/)04850000
 903  FORMAT(41H INPUT ERROR  --  EMMAX1 MUST BE .GE. 0.0/)             04860000
 904  FORMAT(40H INPUT ERROR  --  ACCUR MUST BE .GT. 0.0/)              04870000
 905  FORMAT(53H INPUT ERROR  --  CHARGE NUMBER AND MASS NUMBER MUST ,  04880000
     19HBE .GT. 0/)                                                     04890000
 906  FORMAT(53H INPUT ERROR  --  CHARGE NUMBER MUST BE .LE. MASS NUM,  04900000
     13HBER/)                                                           04910000
 907  FORMAT(53H INPUT ERROR  --  ENERGY OF PROJECTILE MUST BE .GT. 0/) 04920000
 908  FORMAT(53H INPUT ERROR  --  SCATTERING ANGLE MUST BE BETWEEN 0 ,  04930000
     115HAND 180 DEGREES/)                                              04940000
 909  FORMAT(53H INPUT ERROR  --  LEVEL INDEX MUST BE .GE. 1 AND .LE.,  04950000
     11H ,I2/)                                                          04960000
 910  FORMAT(54H INPUT ERROR  --  SPIN QUANTUM NUMBER MUST BE .GE. 0.0/)04970000
 911  FORMAT(41H INPUT ERROR  --  ENERGY MUST BE .GE. 0.0/)             04980000
 912  FORMAT(51H INPUT ERROR  --  IPAR(N) MUST BE EQUAL 1 FOR EVEN ,    04990000
     128HPARITY AND -1 FOR ODD PARITY/)                                 05000000
 913  FORMAT(53H INPUT ERROR  --  MULTIPOLARITY MUST BE .GE. 1 AND .L,  05010000
     14HE. 6/)                                                          05020000
 914  FORMAT(50H INPUT ERROR  --  NGMAX MUST BE .GE. 1 AND .LE. 10/)    05030000
 915  FORMAT(53H INPUT ERROR  --  GROUP INDEX MUST BE .GE. 1 AND .LE.,  05040000
     13H 10/)                                                           05050000
 916  FORMAT(53H INPUT ERROR  --  NSTART(I) AND NSTOP(I) MUST BE .GE.,  05060000
     112H 1 AND .LE. ,I2/)                                              05070000
 917  FORMAT(53H INPUT ERROR  --  NSTOP(I) MUST BE GREATER THAN NSTAR,  05080000
     14HT(I)/)                                                          05090000
 918  FORMAT(43H INPUT ERROR  --  EMMAX(I) MUST BE .GE. 0.0/)           05100000
 919  FORMAT(48H INPUT ERROR  --  IEXCIT(I) MUST BE EQUAL 1 (FOR,       05110000
     158H PROJECTILE EXCITATION) OR EQUAL 2 (FOR TARGET EXCITATION)/)   05120000
 920  FORMAT(42H INPUT ERROR  --  MAXIMUM NUMBER OF LEVELS,             05130000
     120H IN EACH GROUP IS 11)                                          05140000
 921  FORMAT(50H INPUT ERROR  --  THETAC MUST BE BETWEEN 0 AND 180,     05150000
     18H DEGREES)                                                       05160000
 922  FORMAT(48H INPUT ERROR  --  PHIC MUST BE BETWEEN 0 AND 360,       05170000
     18H DEGREES)                                                       05180000
      END                                                               05190000
      SUBROUTINE EULER                                                  05200000
C                                                                       05210000
C     THIS ROUTINE COMPUTES EULERIAN ANGLES FOR TRANSFORMATION FROM     05220000
C     COORDINATE SYSTEM (0) TO COORDINATE SYSTEM (4)                    05230000
C                                                                       05240000
      REAL NX,NY,NZ                                                     05250000
      COMMON/EUL/ALPHA,BETA,GAMMA,THETAC,PHIC                           05260000
      COMMON/RPST/THETA                                                 05270000
      R = 180./ACOS(-1.)                                                05280000
      DFARG = (180.+THETA)/2.                                           05290000
      DFARGR = DFARG/R                                                  05300000
      SINDFA = SIN(DFARGR)                                              05310000
      COSDFA = COS(DFARGR)                                              05320000
      TCR = THETAC/R                                                    05330000
      SINTC = SIN(TCR)                                                  05340000
      COSTC = COS(TCR)                                                  05350000
 200  PCR = PHIC/R                                                      05360000
      SINPC = SIN(PCR)                                                  05370000
      COSPC = COS(PCR)                                                  05380000
      AX = SINDFA                                                       05390000
      AZ = COSDFA                                                       05400000
      BX = SINTC*COSPC                                                  05410000
      BY = SINTC*SINPC                                                  05420000
      BZ = COSTC                                                        05430000
      NX =-AZ*BY                                                        05440000
      NY = AZ*BX - AX*BZ                                                05450000
      NZ = AX*BY                                                        05460000
      ABSN = SQRT(NX*NX+NY*NY+NZ*NZ)                                    05470000
      COSB = AX*BX+AZ*BZ                                                05480000
      IF(ABS(COSB-1.).LT.1.E-12) COSB = 1.                              05490000
      IF(ABS(COSB+1.).LT.1.E-12) COSB = -1.                             05500000
      BETA = ACOS(COSB)*R                                               05510000
      IF(COSB.EQ.1..OR.COSB.EQ.-1..OR.ABSN.EQ.0.)GOTO 300               05520000
      COSA = BY/ABSN                                                    05530000
      IF(ABS(COSA-1.).LT.1.E-12) COSA = 1.                              05540000
      IF(ABS(COSA+1.).LT.1.E-12) COSA = -1.                             05550000
      ALPHA = ACOS(COSA)*R                                              05560000
      IF(NY.LE.0.)GOTO 400                                              05570000
      ALPHA = -ALPHA                                                    05580000
      GOTO 400                                                          05590000
 300  ALPHA = 0.                                                        05600000
 400  CONTINUE                                                          05610000
      IF(ABS(BY).LT.1.E-12.AND.ABS(ABS(ALPHA)-90.).LT.1.E-12) GOTO 450  05620000
      IF(ABS(BY).LT.1.E-12.AND.ABSN.LT.1.E-12)GOTO 460                  05630000
      GY = -BZ/BY                                                       05640000
      GZ = 1.                                                           05650000
      IF(GY.GE.0.)GOTO 420                                              05660000
      GY = -GY                                                          05670000
      GZ = -GZ                                                          05680000
 420  GXA = GZ*AZ                                                       05690000
      IF(ABSN.EQ.0.)GOTO 460                                            05700000
      ABSG = SQRT(1.+GY*GY)                                             05710000
      COSG = (NY*GY+NZ*GZ)/(ABSN*ABSG)                                  05720000
      IF(ABS(COSG-1.).LT.1.E-12) COSG = 1.                              05730000
      IF(ABS(COSG+1.).LT.1.E-12) COSG =-1.                              05740000
      GAMMA = ACOS(COSG)*R                                              05750000
      IF(GXA.LT.0.) GAMMA = 360.-GAMMA                                  05760000
      GOTO 480                                                          05770000
 450  IF(ALPHA.GT.0.) GAMMA = 180.                                      05780000
      IF(ALPHA.LT.0.) GAMMA = 0.                                        05790000
      GOTO 480                                                          05800000
 460  IF(BETA.LT.1.) GAMMA = 270.                                       05810000
      IF(BETA.GT.179.) GAMMA = 90.                                      05820000
 480  RETURN                                                            05830000
      END                                                               05840000
      SUBROUTINE INTG                                                   05850000
C                                                                       05860000
C     THIS ROUTINE PERFORMS INTEGRATION OF COUPLED DIFFERENTIAL EQUATION05870000
C                                                                       05880000
      INTEGER SSTART,SSTOP                                              05890000
      COMPLEX AMP,AMPDOT,AMPP,F,Q1,RK1,RK2,RK3                          05900000
      LOGICAL ERR                                                       05910000
      COMMON/EROR/ERR                                                   05920000
      INTEGER OUAMP,OUPROW                                              05930000
      COMMON/P2I/UP,DW,ISTEP,D2W                                        05940000
      COMMON/IITT/AMP(350,4),LLMAX                                      05950000
      COMMON/IS/P(30)                                                   05960000
      COMMON/RI/OUAMP,OUPROW,INTERV,INTIN                               05970000
      COMMON/ARI/NTIME                                                  05980000
      COMMON/RPI/IT                                                     05990000
      COMMON/RPIS/XIMAX                                                 06000000
      COMMON/P2IS/EPS,EROOT                                             06010000
      COMMON/LARGE/ZETA(20000),NZMAX                                    06020000
      COMMON/PIS/ XI(30,30)                                             06030000
      COMMON /P1IT/ CAT(350,3),ICATMX, ISMAX                            06040000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          06050000
      COMMON/PS/DISTA,VINF                                              06060000
      COMMON/ALL/NMAX,NDIM,NCORR                                        06070000
      COMMON/P2DI/ACC10                                                 06080000
      COMMON/P2IQ/COT1,COT2                                             06090000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       06100000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       06110000
     1SSTART(31),SSTOP(30)                                              06120000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  06130000
      COMMON/IPREP/LMX,IR1,IR2,N1,N2                                    06140000
      COMMON/RDSTA/IPAR(30),IFAC(30)                                    06150000
      DIMENSION Q1(350,4),PROB(350),AMPP(350,4),F(350,4,4),AMPDOT(350,4)06160000
C                                                                       06170000
C     INITIAL CONDITIONS FOR INTEGRATION                                06180000
      INTERV=INTIN                                                      06190000
      ISTEPS=0                                                          06200000
C     ISTEPS COUNTS ACTUAL NUMBER OF STEPS                              06210000
      KAST=0                                                            06220000
      W = -UP                                                           06230000
      DO 82 K=1,IEXNUM                                                  06240000
      LMX = LMAX(K)                                                     06250000
      IR1 = IRSTA(K)                                                    06260000
      IR2 = IRSTO(K)                                                    06270000
      DO 81 L=1,LMX                                                     06280000
      DO 80 IR=IR1,IR2                                                  06290000
      AMP(IR,L) = (0.0,0.0)                                             06300000
      IF(L.EQ.IR-IR1+1) AMP(IR,L) = (1.0,0.0)                           06310000
  80  CONTINUE                                                          06320000
  81  CONTINUE                                                          06330000
  82  CONTINUE                                                          06340000
C     CONSTANTS USED IN RUNGE-KUTTA EQUATIONS                           06350000
      RB1=0.5857864                                                     06360000
      C1=0.1213204                                                      06370000
      RB2=3.4142136                                                     06380000
      C2=-4.1213204                                                     06390000
      ASSIGN 255 TO ITI                                                 06400000
C     HEADING FOR PROW                                                  06410000
      IF(OUPROW.EQ.0) GO TO 399                                         06420000
      WRITE(66,20)(N,N=1,NMAX)                                          06430000
  20  FORMAT(5X,1HW,4X,10(3X,2HP(,I2,1H),4X)/11X,                       06440001
     110(3X,2HP(,I2,1H),4X)/13X,10(3X,2HP(,I2,1H),4X))                  06450001
      P(1)=1.0                                                          06460000
      DO 70 N=2,NMAX                                                    06470000
      P(N) = 0.0                                                        06480000
  70  N1 = NSTART(IP)                                                   06490000
      IF(IEXNUM.EQ.2) P(N1)=1.0                                         06500000
      PTOT = P(1) + P(N1)                                               06510000
      PTOTM1 = PTOT - 1.00                                              06520000
      WRITE(66,25) W,(P(N),N=1,NMAX)                                    06530000
  25  FORMAT(F10.3,10E12.4/11X,10E12.4/11X,10E12.4)                     06540001
C     ****************************************************************  06550000
C     THE RUNGE-KUTTA-GILL INTEGRATION PROCEDURE                        06560000
C     ****************************************************************  06570000
 399  CONTINUE                                                          06580000
      CALL Q(W)                                                         06590000
      DO 903  K=1,IEXNUM                                                06600000
      CALL PREP(K)                                                      06610000
      CALL AMPDER(AMP,AMPDOT,K)                                         06620000
      IF(SPIN(N1).EQ.0.)GOTO 901                                        06630000
      DO 902 L=1,LMX                                                    06640000
      DO 902 IR=IR1,IR2                                                 06650000
      F(IR,L,1) = AMPDOT(IR,L)                                          06660000
 902  CONTINUE                                                          06670000
      GOTO 903                                                          06680000
 901  DO 904 L=1,LMX                                                    06690000
      DO 904 N=N1,N2                                                    06700000
      IR = SSTART(N) - 1                                                06710000
 905  IR = IR + 1                                                       06720000
      F(IR,L,1) = AMPDOT(IR,L)                                          06730000
      IF(CAT(IR,3).LT.-0.1)GOTO 905                                     06740000
 904  CONTINUE                                                          06750000
 903  CONTINUE                                                          06760000
C     **********************************************************        06770000
      DO 907 NAM=2,4                                                    06780000
      DO 911 K=1,IEXNUM                                                 06790000
      CALL PREP(K)                                                      06800000
      IF(SPIN(N1).EQ.0.)GOTO 909                                        06810000
      DO 910 L=1,LMX                                                    06820000
      DO 910 IR=IR1,IR2                                                 06830000
      Q1(IR,L) = DW*AMPDOT(IR,L)                                        06840000
      AMP(IR,L) = AMP(IR,L) + Q1(IR,L)                                  06850000
 910  CONTINUE                                                          06860000
      GOTO 911                                                          06870000
 909  DO 912 L=1,LMX                                                    06880000
      DO 912 N=N1,N2                                                    06890000
      IR = SSTART(N) - 1                                                06900000
 913  IR = IR + 1                                                       06910000
      Q1(IR,L) = DW*AMPDOT(IR,L)                                        06920000
      AMP(IR,L) = AMP(IR,L) + Q1(IR,L)                                  06930000
      MIR = CAT(IR,3)                                                   06940000
      IR1 = IR - 2*MIR                                                  06950000
      AMP(IR1,L) = IFAC(N)*AMP(IR,L)                                    06960000
      IF(CAT(IR,3).LT.-0.1)GOTO 913                                     06970000
 912  CONTINUE                                                          06980000
 911  CONTINUE                                                          06990000
C     ********************************************************          07000000
      W = W + DW                                                        07010000
      CALL Q(W)                                                         07020000
      DO 918 K=1,IEXNUM                                                 07030000
      CALL PREP(K)                                                      07040000
      CALL AMPDER(AMP,AMPDOT,K)                                         07050000
      IF(SPIN(N1).EQ.0.)GOTO 916                                        07060000
      DO 917 L=1,LMX                                                    07070000
      DO 917 IR=IR1,IR2                                                 07080000
      RK1 = DW*AMPDOT(IR,L)                                             07090000
      AMP(IR,L) = AMP(IR,L) + RB1*(RK1-Q1(IR,L))                        07100000
      Q1(IR,L) = RB1*RK1 + C1*Q1(IR,L)                                  07110000
 917  CONTINUE                                                          07120000
      GOTO 918                                                          07130000
 916  DO 919 L=1,LMX                                                    07140000
      DO 919 N=N1,N2                                                    07150000
      IR = SSTART(N) - 1                                                07160000
 970  IR = IR + 1                                                       07170000
      RK1 = DW*AMPDOT(IR,L)                                             07180000
      AMP(IR,L) = AMP(IR,L) + RB1*(RK1-Q1(IR,L))                        07190000
      Q1(IR,L) = RB1*RK1 + C1*Q1(IR,L)                                  07200000
      MIR = CAT(IR,3)                                                   07210000
      IR1 = IR - 2*MIR                                                  07220000
      AMP(IR1,L) = IFAC(N)*AMP(IR,L)                                    07230000
      IF(FLOAT(MIR).LT.-0.1)GOTO 970                                    07240000
 919  CONTINUE                                                          07250000
 918  CONTINUE                                                          07260000
C     ********************************************************          07270000
      DO 924 K=1,IEXNUM                                                 07280000
      CALL PREP(K)                                                      07290000
      CALL AMPDER(AMP,AMPDOT,K)                                         07300000
      IF(SPIN(N1).EQ.0.)GOTO 922                                        07310000
      DO 923 L=1,LMX                                                    07320000
      DO 923 IR=IR1,IR2                                                 07330000
      RK2 = DW*AMPDOT(IR,L)                                             07340000
      AMP(IR,L) = AMP(IR,L) + RB2*(RK2-Q1(IR,L))                        07350000
      Q1(IR,L) = RB2*RK2 + C2*Q1(IR,L)                                  07360000
 923  CONTINUE                                                          07370000
      GOTO 924                                                          07380000
 922  DO 925 L=1,LMX                                                    07390000
      DO 925 N=N1,N2                                                    07400000
      IR = SSTART(N) - 1                                                07410000
 926  IR = IR + 1                                                       07420000
      RK2 = DW*AMPDOT(IR,L)                                             07430000
      AMP(IR,L) = AMP(IR,L) + RB2*(RK2-Q1(IR,L))                        07440000
      Q1(IR,L) = RB2*RK2 + C2*Q1(IR,L)                                  07450000
      MIR = CAT(IR,3)                                                   07460000
      IR1 = IR - 2*MIR                                                  07470000
      AMP(IR1,L) = IFAC(N)*AMP(IR,L)                                    07480000
      IF(FLOAT(MIR).LT.-0.1)GOTO 926                                    07490000
 925  CONTINUE                                                          07500000
 924  CONTINUE                                                          07510000
C     *******************************************************           07520000
      W = W + DW                                                        07530000
      CALL Q(W)                                                         07540000
      DO 931 K=1,IEXNUM                                                 07550000
      CALL PREP(K)                                                      07560000
      CALL AMPDER(AMP,AMPDOT,K)                                         07570000
      IF(SPIN(N1).EQ.0.)GOTO 929                                        07580000
      DO 930 L=1,LMX                                                    07590000
      DO 930 IR=IR1,IR2                                                 07600000
      RK3 = DW*AMPDOT(IR,L)                                             07610000
      AMP(IR,L) = AMP(IR,L) + RK3/3.0 - 2.0*Q1(IR,L)/3.0                07620000
 930  CONTINUE                                                          07630000
      GOTO 931                                                          07640000
 929  DO 932 L=1,LMX                                                    07650000
      DO 932 N=N1,N2                                                    07660000
      IR = SSTART(N) - 1                                                07670000
 933  IR = IR + 1                                                       07680000
      RK3 = DW*AMPDOT(IR,L)                                             07690000
      AMP(IR,L) = AMP(IR,L) + RK3/3.0 - 2.0*Q1(IR,L)/3.0                07700000
      MIR = CAT(IR,3)                                                   07710000
      IR1 = IR - 2*MIR                                                  07720000
      AMP(IR1,L) = IFAC(N)*AMP(IR,L)                                    07730000
      IF(FLOAT(MIR).LT.-0.1)GOTO 933                                    07740000
 932  CONTINUE                                                          07750000
 931  CONTINUE                                                          07760000
C     **************************************************************    07770000
      DO 938 K=1,IEXNUM                                                 07780000
      CALL PREP(K)                                                      07790000
      CALL AMPDER(AMP,AMPDOT,K)                                         07800000
      IF(SPIN(N1).EQ.0.)GOTO 936                                        07810000
      DO 937 L=1,LMX                                                    07820000
      DO 937 IR=IR1,IR2                                                 07830000
      F(IR,L,NAM) = AMPDOT(IR,L)                                        07840000
 937  CONTINUE                                                          07850000
      GOTO 938                                                          07860000
 936  DO 939 L=1,LMX                                                    07870000
      DO 939 N=N1,N2                                                    07880000
      IR = SSTART(N) - 1                                                07890000
 940  IR = IR + 1                                                       07900000
      F(IR,L,NAM) = AMPDOT(IR,L)                                        07910000
      IF(CAT(IR,3).LT.-0.1)GOTO 940                                     07920000
 939  CONTINUE                                                          07930000
 938  CONTINUE                                                          07940000
      ISTEPS = ISTEPS + 1                                               07950000
      KAST = KAST + 1                                                   07960000
 907  CONTINUE                                                          07970000
C     ******************************************************************07980000
C     WE NOW HAVE THE FOUR STARTING VALUES FOR THE DERIVATIVES AND CAN  07990000
C     PROCEED BY THE ADAMS-MOULTON-METHOD                               08000000
C     ******************************************************************08010000
  95  CONTINUE                                                          08020000
      DO 945 K=1,IEXNUM                                                 08030000
      CALL PREP(K)                                                      08040000
      IF(SPIN(N1).EQ.0.)GOTO 943                                        08050000
      DO 944 L=1,LMX                                                    08060000
      DO 944 IR=IR1,IR2                                                 08070000
      AMPP(IR,L) = AMP(IR,L) + DW/12.0*(55.0*F(IR,L,4)-59.0*F(IR,L,3)   08080000
     1+37.0*F(IR,L,2)-9.0*F(IR,L,1))                                    08090000
 944  CONTINUE                                                          08100000
      GOTO 945                                                          08110000
 943  DO 946 L=1,LMX                                                    08120000
      DO 946 N=N1,N2                                                    08130000
      IR = SSTART(N) - 1                                                08140000
 947  IR = IR + 1                                                       08150000
      AMPP(IR,L) = AMP(IR,L) +DW/12.0*(55.0*F(IR,L,4)-59.0*F(IR,L,3)    08160000
     1+37.0*F(IR,L,2)-9.0*F(IR,L,1))                                    08170000
      MIR = CAT(IR,3)                                                   08180000
      IR1 = IR - 2*MIR                                                  08190000
      AMPP(IR1,L) = IFAC(N)*AMPP(IR,L)                                  08200000
      IF(FLOAT(MIR).LT.-0.1)GOTO 947                                    08210000
 946  CONTINUE                                                          08220000
 945  CONTINUE                                                          08230000
C     ******************************************************************08240000
      W = W + DW + DW                                                   08250000
      KAST = KAST + 1                                                   08260000
      ISTEPS = ISTEPS + 1                                               08270000
      CALL Q(W)                                                         08280000
      DO 952 K=1,IEXNUM                                                 08290000
      CALL PREP(K)                                                      08300000
      CALL AMPDER(AMPP,AMPDOT,K)                                        08310000
      IF(SPIN(N1).EQ.0.)GOTO 950                                        08320000
      DO 951 L=1,LMX                                                    08330000
      DO 951 IR=IR1,IR2                                                 08340000
      AMP(IR,L) = AMP(IR,L) + DW/12.0*(9.0*AMPDOT(IR,L)+19.0*F(IR,L,4)  08350000
     1-5.0*F(IR,L,3)+F(IR,L,2))                                         08360000
 951  CONTINUE                                                          08370000
      GOTO 952                                                          08380000
 950  DO 953 L=1,LMX                                                    08390000
      DO 953 N=N1,N2                                                    08400000
      IR = SSTART(N) - 1                                                08410000
 954  IR = IR + 1                                                       08420000
      AMP(IR,L) = AMP(IR,L) + DW/12.0*(9.0*AMPDOT(IR,L)+19.0*F(IR,L,4)  08430000
     1-5.0*F(IR,L,3)+F(IR,L,2))                                         08440000
      MIR = CAT(IR,3)                                                   08450000
      IR1 = IR - 2*MIR                                                  08460000
      AMP(IR1,L) = IFAC(N)*AMP(IR,L)                                    08470000
      IF(FLOAT(MIR).LT.-0.1)GOTO 954                                    08480000
 953  CONTINUE                                                          08490000
 952  CONTINUE                                                          08500000
C     ******************************************************************08510000
      DO 959 K=1,IEXNUM                                                 08520000
      CALL PREP(K)                                                      08530000
      CALL AMPDER(AMP,AMPDOT,K)                                         08540000
      IF(SPIN(N1).EQ.0.)GOTO 957                                        08550000
      DO 958 L=1,LMX                                                    08560000
      DO 958 IR=IR1,IR2                                                 08570000
      F(IR,L,1) = F(IR,L,2)                                             08580000
      F(IR,L,2) = F(IR,L,3)                                             08590000
      F(IR,L,3) = F(IR,L,4)                                             08600000
      F(IR,L,4) = AMPDOT(IR,L)                                          08610000
 958  CONTINUE                                                          08620000
      GOTO 959                                                          08630000
 957  DO 960 L=1,LMX                                                    08640000
      DO 960 N=N1,N2                                                    08650000
      IR = SSTART(N) - 1                                                08660000
 961  IR = IR + 1                                                       08670000
      F(IR,L,1) = F(IR,L,2)                                             08680000
      F(IR,L,2) = F(IR,L,3)                                             08690000
      F(IR,L,3) = F(IR,L,4)                                             08700000
      F(IR,L,4) = AMPDOT(IR,L)                                          08710000
      IF(CAT(IR,3).LT.-0.1)GOTO 961                                     08720000
 960  CONTINUE                                                          08730000
 959  CONTINUE                                                          08740000
C     ******************************************************************08750000
      GOTO ITI,(255,257)                                                08760000
 255  IF(ISTEPS.LT.10) GO TO  579                                       08770000
      TSTEP=ISTEP                                                       08780000
      ASSIGN 257 TO ITI                                                 08790000
 257  CONTINUE                                                          08800000
 579  IF(W+DW.GT.UP) GO TO 571                                          08810000
C                                                                       08820000
C     ACCURACY CONTROL                                                  08830000
C                                                                       08840000
      IF(KAST.LT.INTERV) GO TO 95                                       08850000
      FF=0.0                                                            08860000
      DO 980 K=1,IEXNUM                                                 08870000
      LMX = LMAX(K)                                                     08880000
      IR1 = IRSTA(K)                                                    08890000
      IR2 = IRSTO(K)                                                    08900000
      DO 573 L=1,LMX                                                    08910000
      DO 574 IR=IR1,IR2                                                 08920000
      FZR = REAL(AMPP(IR,L)) - REAL(AMP(IR,L))                          08930000
      FZI = AIMAG(AMPP(IR,L)) - AIMAG(AMP(IR,L))                        08940000
      FZ=(SQRT(FZR*FZR+FZI*FZI))/14.0                                   08950000
      IF(FZ-FF)574,574,21                                               08960000
  21  FF=FZ                                                             08970000
 574  CONTINUE                                                          08980000
 573  CONTINUE                                                          08990000
 980  CONTINUE                                                          09000000
      ACC050 = ACCUR/ 50.0                                              09010000
      IF (FF .LT. ACC050) GOTO 575                                      09020000
      IF (FF .GT. ACCUR) GOTO 577                                       09030000
      GO TO 571                                                         09040000
 575  DW=2.0*DW                                                         09050000
      INTERV=INTERV/2                                                   09060000
      IF(INTERV.EQ.0) INTERV = 1                                        09070000
      D2W=2.*DW                                                         09080000
      WRITE(66,576) W,D2W                                               09090000
 576  FORMAT(8H AT W = ,F7.3,36H, STEP WIDTH WAS DOUBLED TO BE D2W= ,   09100001
     1F8.5)                                                             09110001
      GO TO 571                                                         09120000
 577  CONTINUE                                                          09130000
      DWOLD=DW                                                          09140000
      DW=DWOLD/2.0                                                      09150000
      INTERV=2*INTERV                                                   09160000
      D2W=2.*DW                                                         09170000
      WRITE(66,578) W,D2W                                               09180000
 578  FORMAT(8H AT W = ,F7.3,35H, STEP WIDTH WAS HALVED TO BE D2W= ,    09190001
     1F8.5)                                                             09200001
      KAST = 0                                                          09210000
      GO TO 399                                                         09220000
C     THE EXCITATION PROBABILITIES DURING INTEGRATION                   09230000
 571  DO 10 K=1,IEXNUM                                                  09240000
      N1 = 1                                                            09250000
      IF(K.EQ.2) N1=NSTART(IP)                                          09260000
      LLMAX = 2*(SPIN(N1)+1.1)                                          09270000
      IR1 = IRSTA(K)                                                    09280000
      IR2 = IRSTO(K)                                                    09290000
      DO 52 IR=IR1,IR2                                                  09300000
      PROB(IR) = 0.0                                                    09310000
      L = 1                                                             09320000
      DO 54 LL=2,LLMAX,2                                                09330000
      IF(LL-LLMAX) 50,51,52                                             09340000
  50  FAC = 2.0/(2.0*SPIN(N1)+1.0)                                      09350000
      GOTO 53                                                           09360000
  51  FAC = 1.0/(2.0*SPIN(N1)+1.0)                                      09370000
  53  CONTINUE                                                          09380000
      FZR = REAL(AMP(IR,L))                                             09390000
      FZI = AIMAG(AMP(IR,L))                                            09400000
      PROB(IR) = PROB(IR) + FAC * (FZR*FZR + FZI*FZI)                   09410000
      L = L + 1                                                         09420000
  54  CONTINUE                                                          09430000
  52  CONTINUE                                                          09440000
  10  CONTINUE                                                          09450000
      DO 61 N=1,NMAX                                                    09460000
      P(N) = 0.0                                                        09470000
      IR1 = SSTART(N)                                                   09480000
      IR2 = SSTOP(N)                                                    09490000
      DO 62 IR=IR1,IR2                                                  09500000
  62  P(N) = P(N) + PROB(IR)                                            09510000
  61  CONTINUE                                                          09520000
      PTOTP = 0.0                                                       09530000
      PTOTT = 0.0                                                       09540000
      DO 64 K=1,IEXNUM                                                  09550000
      IF(K.EQ.2)GOTO 66                                                 09560000
      N1 = 1                                                            09570000
      N2 = NMAX                                                         09580000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   09590000
      IGROUP = 1                                                        09600000
      GOTO 67                                                           09610000
  66  N1 = NSTART(IP)                                                   09620000
      N2 = NMAX                                                         09630000
      IGROUP = IP                                                       09640000
  67  IEXC = IEXCIT(IGROUP)                                             09650000
      IF(IEXC.EQ.2)GOTO 412                                             09660000
      DO 411 N=N1,N2                                                    09670000
 411  PTOTP = PTOTP + P(N)                                              09680000
      GOTO 64                                                           09690000
 412  DO 413 N=N1,N2                                                    09700000
 413  PTOTT = PTOTT + P(N)                                              09710000
  64  CONTINUE                                                          09720000
C                                                                       09730000
C     PTOT CONTROL                                                      09740000
      DO 130 K=1,IEXNUM                                                 09750000
      IGROUP = 1                                                        09760000
      IF(K.EQ.2) IGROUP=IP                                              09770000
      IEXC = IEXCIT(IGROUP)                                             09780000
      IF(IEXC.EQ.2)GOTO 135                                             09790000
      ABW = ABS(PTOTP-1.0)/20.0                                         09800000
      IF(ABW.LT.ACCUR)GOTO 130                                          09810000
      WRITE(66,136) W,PTOTP                                             09820000
 136  FORMAT(26H  - -  WARNING  - - AT W= ,F6.3,10X,                    09830001
     121HPTOT FOR PROJECTILE =,F10.6,                                   09840001
     232HERROR IN PTOT EXCEEDS 20 X ACCUR)                              09850001
      GOTO 130                                                          09860000
 135  ABW = ABS(PTOTT-1.0)/20.0                                         09870000
      IF(ABW.LT.ACCUR)GOTO 130                                          09880000
      WRITE(66,137) W,PTOTT                                             09890000
 137  FORMAT(26H  - -  WARNING  - - AT W= ,F6.3,10X,                    09900001
     117HPTOT FOR TARGET =,F10.7,32HERROR IN PTOT EXCEEDS 20 X ACCUR)   09910001
 130  CONTINUE                                                          09920000
      IF(OUPROW)801,802,801                                             09930000
 801  PTOT = PTOTP + PTOTT                                              09940000
C     WRITE (6,973) W, (P(N), N=1,NMAX),PTOT                            09950000
C973  FORMAT (F12.5,10E11.4)                                            09960000
      WRITE(66,25) W,(P(N),N=1,NMAX)                                    09970000
      WRITE(66,26) PTOT                                                 09980000
  26  FORMAT(7H PTOT =,E11.4//)                                         09990000
 802  KAST=0                                                            10000000
      IF(W+DW.GT.UP) GO TO 92                                           10010000
      IF(FF.LT.ACC050) GO TO 399                                        10020000
      GO TO 95                                                          10030000
  92  CONTINUE                                                          10040000
      WRITE(66,790) ISTEPS                                              10050000
 790  FORMAT(34H ACTUAL NUMBER OF STEPS, ISTEPS = ,I4)                  10060001
C                                                                       10070000
C     INTEGRATION COMPLETED                                             10080000
C                                                                       10090000
C     PRINT-OUT OF THE FINAL AMPLITUDES AMP(W=+UP)                      10100000
      IF(OUAMP)350,122,350                                              10110000
 350  DO 981 K=1,IEXNUM                                                 10120000
      LMX = LMAX(K)                                                     10130000
      IF(K.EQ.2)GOTO 982                                                10140000
      N1 = 1                                                            10150000
      IGROUP = 1                                                        10160000
      GOTO 983                                                          10170000
 982  N1 = NSTART(IP)                                                   10180000
      IGROUP = IP                                                       10190000
 983  IEXC = IEXCIT(IGROUP)                                             10200000
      DO 120 L=1,LMX                                                    10210000
      IR1 = SSTART(N1)                                                  10220000
      IRL = IR1 + L - 1                                                 10230000
      IF(IEXC.EQ.2)GOTO 984                                             10240000
      WRITE(66,313) CAT(IRL,3)                                          10250000
 313  FORMAT(13H1INITIAL M = ,F4.1,20X,21HPROJECTILE AMPLITUDES)        10260000
      GOTO 985                                                          10270000
 984  WRITE(66,986) CAT(IRL,3)                                          10280000
 986  FORMAT(13H1INITIAL M = ,F4.1,20X,17HTARGET AMPLITUDES)            10290000
 985  WRITE(66,314)                                                     10300000
 314  FORMAT (1X,4HSPIN,2X,12HMAG.QUAN.NO.,1X,14HREAL AMPLITUDE,1X,     10310001
     114HIMAG AMPLITUDE,3X,10HPOPULATION)                               10320001
      VAL = N1                                                          10330000
      IR1 = IRSTA(K)                                                    10340000
      IR2 = IRSTO(K)                                                    10350000
      DO 120 IZR=IR1,IR2                                                10360000
      POP=(REAL(AMP(IZR,L)))**2+(AIMAG(AMP(IZR,L)))**2                  10370000
      IF(CAT(IZR,1) - VAL) 842,842,840                                  10380000
 840  VAL = CAT(IZR,1)                                                  10390000
      WRITE(66,841)                                                     10400000
 841  FORMAT(1X/)                                                       10410001
 842  WRITE(66,40) (CAT(IZR,LC),LC=2,3), AMP(IZR,L), POP                10420000
  40  FORMAT(1X,F5.1,F9.1,3X,3E15.4)                                    10430001
 120  CONTINUE                                                          10440000
 981  CONTINUE                                                          10450000
 122  CONTINUE                                                          10460000
      RETURN                                                            10470000
      END                                                               10480000
      SUBROUTINE LAISUM(AMP,AMPDOT,IR,N,LMX)                            10490000
C                                                                       10500000
C     THIS ROUTINE COMPUTES AMPDOT(IR,L)                                10510000
C                                                                       10520000
      COMPLEX AMP,AMPDOT,RC,CI                                          10530000
      COMPLEX CQU1,CQU2,CQU3,CQU4,CQU5,CQU6,CQU7,CQU8,CQU9,CQU10,CQU11, 10540000
     1CQU12                                                             10550000
      INTEGER SSTART,SSTOP                                              10560000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       10570000
     1SSTART(31),SSTOP(30)                                              10580000
      COMMON/P2DI/ACC10                                                 10590000
      COMMON/LARGE/ZETA(20000),NZMAX                                    10600000
      COMMON /P1IT/ CAT(350,3),ICATMX, ISMAX                            10610000
      COMMON/CMPQ1/CQU1(7,30,30),CQU2(7,30,30),CQU3(7,30,30)            10620000
      COMMON/CMPQ2/CQU4(7,30,30),CQU5(7,30,30),CQU6(7,30,30)            10630000
      COMMON/CMPQ3/CQU7(7,30,30),CQU8(7,30,30),CQU9(7,30,30)            10640000
      COMMON/CMPQ4/CQU10(7,30,30),CQU11(7,30,30),CQU12(7,30,30)         10650000
      COMMON/AMPLAI/NZ                                                  10660000
      DIMENSION AMP(350,4),AMPDOT(350,4)                                10670000
      DATA CI/(0.0,1.0)/                                                10680000
C                                                                       10690000
 800  CONTINUE                                                          10700000
      RMIR = CAT(IR,3)                                                  10710000
      DO 45 L=1,LMX                                                     10720000
  45  AMPDOT(IR,L) = (0.0,0.0)                                          10730000
      DO 51 I1=1,LAMMAX                                                 10740000
      LAM = LAMDA(I1)                                                   10750000
      LA = LAM                                                          10760000
      IF(LAM.GT.6) LAM=LAM-6                                            10770000
      LD = LDNUM(LA,N)                                                  10780000
      IF(LD.EQ.0)GOTO 51                                                10790000
      DO 52 I2=1,LD                                                     10800000
      M = LEAD(N,I2,LA)                                                 10810000
      ISMIN = 0                                                         10820000
      IS1 = SSTART(M)                                                   10830000
      ISPLUS = IFIX(RMIR-CAT(IS1,3))-LAM                                10840000
      IF(ISPLUS.GE.0)GOTO 10                                            10850000
      ISMIN = ISPLUS                                                    10860000
      ISPLUS = 0                                                        10870000
  10  IS2 = IS1+ISPLUS-1                                                10880000
      MRANGE = 2*LAM+1+ISMIN                                            10890000
      IF(IS2+MRANGE.GT.SSTOP(M)) MRANGE=SSTOP(M)-IS2                    10900000
      IF(MRANGE.LE.0)GOTO 52                                            10910000
      DO 53 I3=1,MRANGE                                                 10920000
      IS = IS2+I3                                                       10930000
      NZ = NZ + 1                                                       10940000
      Z = ZETA(NZ)                                                      10950000
CA    IF(ABS(Z).LE.ACC10)GOTO 53                                        10960000
      DO 54 L=1,LMX                                                     10970000
C     ******* KORREKTUR ***********                                     10980000
C     MUA = ABS(RMIR-CAT(IS,3))+1.1                                     10990000
      RMU = CAT(IS,3)-RMIR                                              11000000
      MUA = ABS(RMU)+1.1                                                11010000
C     *****************************                                     11020000
      GOTO(111,222,333,444,555,666,670,680,690,700,710,720),LA          11030000
 111  RC = CQU1(MUA,N,M)*AMP(IS,L)*Z                                    11040000
      GOTO 2                                                            11050000
 222  RC = CQU2(MUA,N,M)*AMP(IS,L)*Z                                    11060000
      GOTO 2                                                            11070000
 333  RC = CQU3(MUA,N,M)*AMP(IS,L)*Z                                    11080000
      GOTO 2                                                            11090000
 444  RC = CQU4(MUA,N,M)*AMP(IS,L)*Z                                    11100000
      GOTO 2                                                            11110000
 555  RC = CQU5(MUA,N,M)*AMP(IS,L)*Z                                    11120000
      GOTO 2                                                            11130000
 666  RC = CQU6(MUA,N,M)*AMP(IS,L)*Z                                    11140000
      GOTO 2                                                            11150000
 670  RC = CQU7(MUA,N,M)*AMP(IS,L)*Z                                    11160000
      IF(RMU.LT.-0.1) RC=-RC                                            11170000
      GOTO 2                                                            11180000
 680  RC = CQU8(MUA,N,M)*AMP(IS,L)*Z                                    11190000
      IF(RMU.LT.-0.1) RC=-RC                                            11200000
      GOTO 2                                                            11210000
 690  RC = CQU9(MUA,N,M)*AMP(IS,L)*Z                                    11220000
      IF(RMU.LT.-0.1) RC=-RC                                            11230000
      GOTO 2                                                            11240000
 700  RC =CQU10(MUA,N,M)*AMP(IS,L)*Z                                    11250000
      IF(RMU.LT.-0.1) RC=-RC                                            11260000
      GOTO 2                                                            11270000
 710  RC =CQU11(MUA,N,M)*AMP(IS,L)*Z                                    11280000
      IF(RMU.LT.-0.1) RC=-RC                                            11290000
      GOTO 2                                                            11300000
 720  RC =CQU12(MUA,N,M)*AMP(IS,L)*Z                                    11310000
      IF(RMU.LT.-0.1) RC=-RC                                            11320000
   2  AMPDOT(IR,L) = AMPDOT(IR,L) - CI*RC                               11330000
  54  CONTINUE                                                          11340000
  53  CONTINUE                                                          11350000
  52  CONTINUE                                                          11360000
  51  CONTINUE                                                          11370000
      RETURN                                                            11380000
      END                                                               11390000
      SUBROUTINE LSLOOP(IR,N,NZ)                                        11400000
C                                                                       11410000
C     THIS ROUTINE COMPUTES ZETA-ARRAY                                  11420000
C                                                                       11430000
      INTEGER SSTART,SSTOP                                              11440000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       11450000
     1SSTART(31),SSTOP(30)                                              11460000
      COMMON/LARGE/ZETA(20000),NZMAX                                    11470000
      COMMON /P1IT/ CAT(350,3),ICATMX, ISMAX                            11480000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          11490000
      COMMON/PR1LSL/PSI(30,30,12)                                       11500000
C     LAMDA - LOOP  AND  IS - LOOP  FOR EACH IR                         11510000
 150  SPINR = CAT(IR,2)                                                 11520000
      RMIR = CAT(IR,3)                                                  11530000
      DO 501 I1=1,LAMMAX                                                11540000
      LAM = LAMDA(I1)                                                   11550000
      LA = LAM                                                          11560000
      IF(LAM.GT.6) LAM=LAM-6                                            11570000
      RRLAM = FLOAT(LAM)                                                11580000
      SSSQRT = SQRT(2.0*RRLAM+1.0)                                      11590000
      LD = LDNUM(LA,N)                                                  11600000
      IF(LD.EQ.0)GOTO 501                                               11610000
      DO 502 I2=1,LD                                                    11620000
      M = LEAD(N,I2,LA)                                                 11630000
      ISMIN = 0                                                         11640000
      SPINS = SPIN(M)                                                   11650000
      IS1 = SSTART(M)                                                   11660000
      ISPLUS = IFIX(RMIR-CAT(IS1,3))-LAM                                11670000
      IF(ISPLUS.GE.0)GOTO 22                                            11680000
      ISMIN = ISPLUS                                                    11690000
      ISPLUS = 0                                                        11700000
  22  IS2 = IS1+ISPLUS-1                                                11710000
      MRANGE = 2*LAM+1+ISMIN                                            11720000
      IF(IS2+MRANGE.GT.SSTOP(M)) MRANGE = SSTOP(M)-IS2                  11730000
      IF(MRANGE.LE.0)GOTO 502                                           11740000
      DO 503 I3=1,MRANGE                                                11750000
      IS = IS2+I3                                                       11760000
      RMIS = CAT(IS,3)                                                  11770000
      G1 = -RMIS                                                        11780000
      G2 = RMIS - RMIR                                                  11790000
      NZ = NZ + 1                                                       11800000
      IF(NZ.GT.NZMAX) GOTO 503                                          11810000
      IIEX = SPINS - RMIS                                               11820000
CPHASEIIEX = SPINS - RMIS +FLOAT(LAM) + 0.01                            11830000
      PPHZ = (-1.0)**IIEX                                               11840000
      P = PSI(N,M,LA)                                                   11850000
C     WRITE(66,510)P                                                    11860000
 510  FORMAT(///6H PSI =,F10.4)                                         11870000
C     WRITE(66,511)SPINS,G1,RRLAM,G2,SPINR,RMIR                         11880000
 511  FORMAT(8H SPINS =,F7.2,6X,4HG1 =,F7.2,6X,7HRRLAM =,F7.2,6X,       11890000
     14HG2 =,F7.2,6X,7HSPINR =,F7.2,6X,5HMIR =,F7.2)                    11900000
      ZETA(NZ)=PPHZ*PSI(N,M,LA)*SSSQRT*THREEJ(SPINS,G1,RRLAM,G2,SPINR,  11910000
     1RMIR)                                                             11920000
C     WRITE(66,620) NZ,IR,IS,LA,ZETA(NZ)                                11930000
 620  FORMAT(1H ,4HNZ =,I4,6X,4HIR =,I4,6X,4HIS =,I4,6X,5HLAM =,I2,6X,  11940000
     16HZETA =,F12.4)                                                   11950000
 503  CONTINUE                                                          11960000
 502  CONTINUE                                                          11970000
 501  CONTINUE                                                          11980000
      RETURN                                                            11990000
      END                                                               12000000
      SUBROUTINE MAT                                                    12010000
C                                                                       12020000
C     THIS ROUTINE NEEDS MATRIX ELEMENTS ME(N,M,LAMD)                   12030000
C     IT SYMMETRISES MATRIX                                             12040000
C                                                                       12050000
      REAL ME,MTR                                                       12060000
      INTEGER SSTART,SSTOP                                              12070000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       12080000
     1SSTART(31),SSTOP(30)                                              12090000
      COMMON/ALL/NMAX,NDIM,NCORR                                        12100000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  12110000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          12120000
      COMMON/RP1M/ME(30,30,12)                                          12130000
      COMMON/RDSTA/IPAR(30),IFAC(30)                                    12140000
C                                                                       12150000
      ACC10=ACCUR/10.                                                   12160000
      IERROR = 0                                                        12170000
      DO 10 N=1,NMAX                                                    12180000
      DO 10 M=N,NMAX                                                    12190000
      DO 8 I=1,LAMMAX                                                   12200000
      LAM = LAMDA(I)                                                    12210000
      LA = LAM                                                          12220000
      IF(LAM.GT.6) LA=LAM-6                                             12230000
      MTR=ME(N,M,LAM)                                                   12240000
      IF(MTR.EQ.0.0) GOTO 50                                            12250000
      IF(ABS(SPIN(N)-LA).LE.SPIN(M).AND.SPIN(M).LE.(SPIN(N)+LA))GOTO 50 12260000
      IERROR = 1                                                        12270000
      WRITE(66,90) N,M,LA                                               12280000
  90  FORMAT(39H ERROR IN INPUT MATRIX ELEMENTS FOR N =,I2,4H M =,I2,   12290001
     16H LAM =,I2,45H  ---  ANGULAR MOMENTUM CONSERVATION VIOLATED)     12300001
C     PARITY CONSERVATION CONTROL                                       12310000
      IDP = 1                                                           12320000
      IF(IPAR(N).NE.IPAR(M)) IDP=-1                                     12330000
      L = LA                                                            12340000
      IF(LAM.GT.6) L=LA+1                                               12350000
      IF(IDP.EQ.(-1)**L)GOTO 50                                         12360000
      IERROR = 1                                                        12370000
      WRITE(66,110) N,M,LA                                              12380000
 110  FORMAT(39H ERROR IN INPUT MATRIX ELEMENTS FOR N =,I2,4H M =,I2,   12390001
     16H LAM =,I2,35H  ---  PARITY CONSERVATION VIOLATED)               12400001
  50  IF(ABS(MTR)-ACC10)5,3,3                                           12410000
   5  ME(N,M,LAM)=0.0                                                   12420000
   3  IF(M.EQ.N)GOTO 8                                                  12430000
C     SYMMETRISATION OF MATRICES                                        12440000
   7  FAC = (-1.)**IFIX(ABS(SPIN(N)-SPIN(M))+0.001)                     12450000
      ME(M,N,LAM) = FAC*MTR                                             12460000
   8  CONTINUE                                                          12470000
  10  CONTINUE                                                          12480000
C     CALLS EXIT IF ERROR IN INPUT MATRIX ELEMENTS                      12490000
      IF(IERROR.EQ.1) STOP                                              12500000
      RETURN                                                            12510000
      END                                                               12520000
      SUBROUTINE MATROT                                                 12530000
C                                                                       12540000
C     SUBROUTINE TO GENERATE THE E2 MATRIX ELEMENTS OF A                12550000
C     ROTATIONAL NUCLEUS WITH STRETCHING                                12560000
C                                                                       12570000
      REAL MULT,ME                                                      12580000
      INTEGER SSTART,SSTOP                                              12590000
      COMMON/ALL/NMAX,NDIM,NCORR                                        12600000
      COMMON/EMR/QZERO,ALPHA0,ALPHA2,QUINT2,QUINT4,QUINT6               12610000
      COMMON/RP1M/ME(30,30,12)                                          12620000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          12630000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       12640000
     1SSTART(31),SSTOP(30)                                              12650000
      DIMENSION MULT(30,30)                                             12660000
C                                                                       12670000
      DO 38 N=1,NMAX                                                    12680000
      DO 38M=1,NMAX                                                     12690000
      SPINY =(SPIN(N)*(SPIN(N)+1.0))+(SPIN(M)*(SPIN(M)+1.0))            12700000
      MULT(N,M)=1.0+0.5*(ALPHA0     +ALPHA2    )*SPINY                  12710000
      IF(N.EQ.M) MULT(N,M)=1.0+0.5*(ALPHA0     -3.0*ALPHA2     )*SPINY  12720000
  38  CONTINUE                                                          12730000
C     IF YOU WANT TO CHANGE THE VALUE OF AN ELEMENT OF MULT(N,M)        12740000
C     DO IT BELOW THIS CARD                                             12750000
      AM1= -SPIN(1)                                                     12760000
      AM3 = SPIN(1)                                                     12770000
      K2 = 0                                                            12780000
      K4 = 0                                                            12790000
      K6 = 0                                                            12800000
      DO 505 N = 1,NMAX                                                 12810000
      AJ3 = SPIN(N)                                                     12820000
      ROOTN = SQRT(2.0*SPIN(N) + 1.0)                                   12830000
      DO 505 M = 1,NMAX                                                 12840000
      AJ1 = SPIN(M)                                                     12850000
      ROOTM = SQRT(SPIN(M)*2.0 + 1.0)                                   12860000
      IEX=ABS(SPIN(M)-SPIN(1))+1.001                                    12870000
      PHZ = (-1.0)**IEX                                                 12880000
      IF(QUINT2.EQ.0.0)GOTO 100                                         12890000
      LAM = 2                                                           12900000
      TRJ2=THREEJ(AJ1,AM1,2.00,0.0,AJ3,AM3)                             12910000
      ME(N,M,2)=PHZ*ROOTN*ROOTM*QUINT2*MULT(N,M)*TRJ2                   12920000
      IF(ME(N,M,2).EQ.0.0)GOTO 100                                      12930000
      I = 1                                                             12940000
      K2 = K2 + 1                                                       12950000
      IF(K2.EQ.1)GOTO 700                                               12960000
 100  IF(QUINT4.EQ.0.0)GOTO 200                                         12970000
      LAM = 4                                                           12980000
      TRJ4=THREEJ(AJ1,AM1,4.00,0.0,AJ3,AM3)                             12990000
      ME(N,M,4)=-PHZ*ROOTN*ROOTM*QUINT4*TRJ4                            13000000
      IF(ME(N,M,4).EQ.0.0)GOTO 200                                      13010000
      I = 2                                                             13020000
      K4 = K4 + 1                                                       13030000
      IF(K4.EQ.1)GOTO 700                                               13040000
 200  IF(QUINT6.EQ.0.0)GOTO 505                                         13050000
      LAM = 6                                                           13060000
      TRJ6=THREEJ(AJ1,AM1,6.00,0.0,AJ3,AM3)                             13070000
      ME(N,M,6)=PHZ*ROOTN*ROOTM*QUINT6*TRJ6                             13080000
      IF(ME(N,M,6).EQ.0.0)GOTO 505                                      13090000
      I = 3                                                             13100000
      K6 = K6 + 1                                                       13110000
      IF(K6.NE.1)GOTO 505                                               13120000
 700  IF(LAM.EQ.LAMDA(1).OR.LAM.EQ.LAMDA(2).OR.LAM.EQ.LAMDA(3).OR.LAM.EQ13130000
     1.LAMDA(4).OR.LAM.EQ.LAMDA(5).OR.LAM.EQ.LAMDA(6).OR.LAM.EQ.LAMDA(7)13140000
     2.OR.LAM.EQ.LAMDA(8).OR.LAM.EQ.LAMDA(9).OR.LAM.EQ.LAMDA(10).OR.LAM.13150000
     3EQ.LAMDA(11).OR.LAM.EQ.LAMDA(12))GOTO 16                          13160000
      LAMMAX = LAMMAX + 1                                               13170000
      LAMDA(LAMMAX) = LAM                                               13180000
  16  IF(I.EQ.1)GOTO 100                                                13190000
      IF(I.EQ.2)GOTO 200                                                13200000
 505  CONTINUE                                                          13210000
      WRITE(66,43)                                                      13220000
  43  FORMAT(33H ROTATIONAL MODEL WITH STRETCHING/ 9X,5HQZERO,9X,       13230001
     16HALPHA0,8X,6HALPHA2)                                             13240001
      WRITE(66,44) QZERO,ALPHA0,ALPHA2                                  13250000
  44  FORMAT(1X,3(4X,F10.4))                                            13260000
      WRITE(66,205)                                                     13270000
 205  FORMAT(1X/10X,15HTHE MULT MATRIX )                                13280001
      WRITE(66,600) (M,M=1,NMAX)                                        13290000
 600  FORMAT(I11,21I6)                                                  13300000
      DO 504 N= 1,NMAX                                                  13310000
      WRITE(66,207)N,(MULT(N,M),M=1,NMAX)                               13320000
 207  FORMAT(4H N =,I2,21F6.3)                                          13330001
 504  CONTINUE                                                          13340000
      WRITE(66,441)                                                     13350000
 441  FORMAT(53H QUADRUPOLE MATRIX ELEMENTS IN BARNS, CALCULATED FROM,  13360001
     11X,25HQZERO, ALPHA0 AND ALPHA2 )                                  13370001
      RETURN                                                            13380000
      END                                                               13390000
      SUBROUTINE PREP(K)                                                13400000
C                                                                       13410000
C     THIS ROUTINE IS PART OF THE INTEGRATION ROUTINE                   13420000
C                                                                       13430000
      COMMON/IPREP/LMX,IR1,IR2,N1,N2                                    13440000
      COMMON/ALL/NMAX,NDIM,NCORR                                        13450000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       13460000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  13470000
C                                                                       13480000
      LMX = LMAX(K)                                                     13490000
      IR1 = IRSTA(K)                                                    13500000
      IR2 = IRSTO(K)                                                    13510000
      IF(K.EQ.2)GOTO 105                                                13520000
 100  N1 = 1                                                            13530000
      N2 = NMAX                                                         13540000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   13550000
      RETURN                                                            13560000
 105  N1 = NSTART(IP)                                                   13570000
      N2 = NMAX                                                         13580000
      RETURN                                                            13590000
      END                                                               13600000
      SUBROUTINE PR1                                                    13610000
C                                                                       13620000
C     THIS ROUTINE PREPARES THE INTEGRATION                             13630000
C     IT COMPUTES XI-MATRIX,PSI-MATRIX,LEAD-MATRIX,SSTART- AND SSTOP-ARR13640000
C                                                                       13650000
      INTEGER OUXI,OUPSI                                                13660000
      LOGICAL ERR                                                       13670000
      INTEGER SSTART,SSTOP                                              13680000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  13690000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       13700000
     1SSTART(31),SSTOP(30)                                              13710000
      COMMON/EROR/ERR                                                   13720000
      COMMON/LARGE/ZETA(20000),NZMAX                                    13730000
      COMMON/RPST/THETA                                                 13740000
      COMMON/P/XIM                                                      13750000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   13760000
      COMMON/RP/OUXI,OUPSI,NCM,EMMAX1                                   13770000
      COMMON/RPI/IT                                                     13780000
      COMMON/RPIS/XIMAX                                                 13790000
      COMMON/PIS/ XI(30,30)                                             13800000
      COMMON /P1IT/ CAT(350,3),ICATMX, ISMAX                            13810000
      REAL ME                                                           13820000
      COMMON/RP1M/ME(30,30,12)                                          13830000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          13840000
      COMMON/PS/DISTA,VINF                                              13850000
      COMMON/ALL/NMAX,NDIM,NCORR                                        13860000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       13870000
      DIMENSION ETAN(30)                                                13880000
      COMMON/PR1LSL/ PSI(30,30,12)                                      13890000
      COMMON/WOLLER/QUE                                                 13900000
      DIMENSION CPSI(12)                                                13910000
C                                                                       13920000
C ************** E1 POLARISATION ************************************** 13930000
      QUE=QPAR*EP*A2/(Z2*Z2*(1.+A1/A2))                                 13940000
C ********************************************************************* 13950000
      DISTR = 1.45*(A1**0.3333 + A2**0.3333)                            13960000
      DISTA=0.0719949*(1.0+A1/A2)*Z1*Z2/EP                              13970000
      IF(DISTA*20.0.GT.DISTR+2.8) GO TO  40                             13980000
CDC   TCRIT=2.0* ASIN(DISTA*20./(DISTR+2.8))*57.295779                  13990000
      TCRIT=2.0*ASIN(DISTA*20./(DISTR+2.8))*57.295779                   14000000
      VINF=SQRT(EP/A1)*0.0463371                                        14010000
      WRITE(66,41) TCRIT                                                14020000
  41  FORMAT(69H BOMBARDING ENERGY TOO HIGH FOR HEAD-ON COLLISIONS, CRIT14030001
     1ICAL ANGLE = ,F6.2,8H DEGREES)                                    14040001
C     COMPUTATION OF XI MATRIX                                          14050000
  40  CONTINUE                                                          14060000
      ETA=Z1*Z2*SQRT(A1/EP)/6.349770                                    14070000
      DO 52 M=1,NMAX                                                    14080000
      DEP=(1.0+A1/A2)*(EN(M)-EN(1))                                     14090000
      ZET=DEP/EP                                                        14100000
      SZET=SQRT(1.0-ZET)                                                14110000
      ETAN(M)=ETA/SZET                                                  14120000
  52  CONTINUE                                                          14130000
      DO 3 N=1,NMAX                                                     14140000
      DO 3 M=1,NMAX                                                     14150000
      XI(N,M) = 99.9                                                    14160000
   3  CONTINUE                                                          14170000
      DO 70 I1=1,LAMMAX                                                 14180000
      LAM = LAMDA(I1)                                                   14190000
      DO 71 N=1,NMAX                                                    14200000
      DO 72 M=1,NMAX                                                    14210000
      IF( ME(N,M,LAM).EQ.0.0 ) GOTO 72                                  14220000
      XI(N,M) = ETAN(N) - ETAN(M)                                       14230000
  72  CONTINUE                                                          14240000
  71  CONTINUE                                                          14250000
  70  CONTINUE                                                          14260000
      IF(OUXI)5,452,5                                                   14270000
   5  WRITE(66,203)                                                     14280000
 203  FORMAT(10H XI MATRIX)                                             14290001
      DO 700 I=1,NGMAX                                                  14300000
      N1 = NSTART(I)                                                    14310000
      N2 = NSTOP(I)                                                     14320000
      DO 710 J=1,NGMAX                                                  14330000
      IF(MISTER(I,J).EQ.0)GOTO 710                                      14340000
      M1 = NSTART(J)                                                    14350000
      M2 = NSTOP(J)                                                     14360000
      WRITE(66,711) I,J                                                 14370000
 711  FORMAT(1X/5X,23HGROUP COMBINATION  I1 =,I2,6H, I2 =,I2)           14380001
      WRITE(66,712) (M,M=M1,M2)                                         14390000
 712  FORMAT(6X,I14,10I11)                                              14400000
      DO 720 N=N1,N2                                                    14410000
      WRITE(66,715) N,(XI(N,M),M=M1,M2)                                 14420000
 715  FORMAT(1X/5X,3HN =,I2,11F11.4)                                    14430001
 720  CONTINUE                                                          14440000
 710  CONTINUE                                                          14450000
 700  CONTINUE                                                          14460000
C    COMPUTATION OF LEAD - MATRIX                                       14470000
 452  CONTINUE                                                          14480000
      DO 100 I5=1,LAMMAX                                                14490000
      LAM = LAMDA(I5)                                                   14500000
      DO 110 I1=1,NGMAX                                                 14510000
      N1 = NSTART(I1)                                                   14520000
      N2 = NSTOP(I1)                                                    14530000
      DO 111 N=N1,N2                                                    14540000
      J = 0                                                             14550000
      DO 120 I2=1,NGMAX                                                 14560000
      IF ( MISTER(I1,I2).EQ.0 ) GOTO 120                                14570000
      M1 = NSTART(I2)                                                   14580000
      M2 = NSTOP(I2)                                                    14590000
      DO 121 M=M1,M2                                                    14600000
CA    IF ( ABS(XI(N,M)).GT.XIMAX ) GOTO 121                             14610000
      IF ( ME(N,M,LAM).EQ.0.0 ) GOTO 121                                14620000
      J = J + 1                                                         14630000
      LEAD(N,J,LAM) = M                                                 14640000
 121  CONTINUE                                                          14650000
 120  CONTINUE                                                          14660000
      LDNUM(LAM,N) = J                                                  14670000
 111  CONTINUE                                                          14680000
 110  CONTINUE                                                          14690000
 100  CONTINUE                                                          14700000
C     COMPUTATION OF PSI MATRIX                                         14710000
      AAZZ=1./(1.+A1/A2)/Z1/Z2                                          14720000
      VDC = 0.0463365*SQRT(EP/A1)                                       14730000
      CPSI(1) = 5.169285*AAZZ                                           14740000
      CPSI(2) = 14.359366*AAZZ*AAZZ                                     14750000
      CPSI(3) = 56.982566 *AAZZ**3                                      14760000
      CPSI(4) = 263.812592*AAZZ**4                                      14770000
      CPSI(5) =1332.409206*AAZZ**5                                      14780000
      CPSI(6) =7117.690088*AAZZ**6                                      14790000
      CPSI(7) = VDC*CPSI(1)/95.0981942                                  14800000
      CPSI(8) = VDC*CPSI(2)/95.0981942                                  14810000
      CPSI(9) = VDC*CPSI(3)/95.0981942                                  14820000
      CPSI(10)= VDC*CPSI(4)/95.0981942                                  14830000
      CPSI(11)= VDC*CPSI(5)/95.0981942                                  14840000
      CPSI(12)= VDC*CPSI(6)/95.0981942                                  14850000
      DO 4 I1=1,LAMMAX                                                  14860000
      LAM = LAMDA(I1)                                                   14870000
      LAM1 = LAM                                                        14880000
      IF(LAM.GT.6) LAM1=LAM-6                                           14890000
      DO 82 I2=1,NGMAX                                                  14900000
      Z = Z1                                                            14910000
C     THE FOLLOWING STATEMENT MEANS: FOR PROJECTILE EXCITATION   Z = Z2 14920000
      IF(IEXCIT(I2).EQ.1) Z=Z2                                          14930000
      ZSQA = Z*SQRT(A1)                                                 14940000
      N1 = NSTART(I2)                                                   14950000
      N2 = NSTOP(I2)                                                    14960000
      DO 8 N=N1,N2                                                      14970000
      PP1 = (EP-(1.0+A1/A2)*EN(N))**0.25                                14980000
      DO 8 M=1,NMAX                                                     14990000
      IF(ME(N,M,LAM).EQ.0.0)GOTO 13                                     15000000
      PP2 = (EP-(1.0+A1/A2)*EN(M))**0.25                                15010000
      PSI(N,M,LAM)=CPSI(LAM)*ZSQA*(PP1*PP2)**(2*LAM1-1)*ME(N,M,LAM)     15020000
      GOTO 8                                                            15030000
  13  PSI(N,M,LAM) = 0.0                                                15040000
   8  CONTINUE                                                          15050000
  82  CONTINUE                                                          15060000
   4  CONTINUE                                                          15070000
      IF(OUPSI)10,11,10                                                 15080000
  10  CONTINUE                                                          15090000
      WRITE(66,300)                                                     15100000
 300  FORMAT(1H1)                                                       15110000
      DO 301 I1=1,LAMMAX                                                15120000
      LAM = LAMDA(I1)                                                   15130000
      WRITE(66,302) LAM                                                 15140000
 302  FORMAT(/25H PSI MATRIX FOR   LAMDA =,I2)                          15150001
      DO 750 I=1,NGMAX                                                  15160000
      N1 = NSTART(I)                                                    15170000
      N2 = NSTOP(I)                                                     15180000
      DO 760 J=1,NGMAX                                                  15190000
      IF(MISTER(I,J).EQ.0)GOTO 760                                      15200000
      M1 = NSTART(J)                                                    15210000
      M2 = NSTOP(J)                                                     15220000
      WRITE(66,711) I,J                                                 15230000
      WRITE(66,712) (M,M=M1,M2)                                         15240000
      DO 770 N=N1,N2                                                    15250000
      WRITE(66,715) N,(PSI(N,M,LAM),M=M1,M2)                            15260000
 770  CONTINUE                                                          15270000
 760  CONTINUE                                                          15280000
 750  CONTINUE                                                          15290000
 301  CONTINUE                                                          15300000
  11  CONTINUE                                                          15310000
C     CATALOGUE OF MAGNETIC SUBSTATES                                   15320000
      IS = 1                                                            15330000
      SSTART(1) = 1                                                     15340000
      DO 19 I1=1,NGMAX                                                  15350000
      N1 = NSTART(I1)                                                   15360000
      N2 = NSTOP(I1)                                                    15370000
      DO 18 N= N1,N2                                                    15380000
      QUAN = SPIN(N)                                                    15390000
      IF(QUAN.GT.EMMAX(I1))QUAN = EMMAX(I1)                             15400000
      MSTOP = 2.0*QUAN + 1.0001                                         15410000
      QUAN = -QUAN                                                      15420000
      DO 15 I = 1,MSTOP                                                 15430000
      IF ( IS.GT.ICATMX ) GOTO 20                                       15440000
      CAT(IS,1) = N                                                     15450000
      CAT(IS,2)= SPIN(N)                                                15460000
      CAT(IS,3) = QUAN                                                  15470000
  20  QUAN = QUAN +1.0                                                  15480000
      IS = IS + 1                                                       15490000
  15  CONTINUE                                                          15500000
      SSTART(N+1) = IS                                                  15510000
      SSTOP(N) = IS - 1                                                 15520000
  18  CONTINUE                                                          15530000
  19  CONTINUE                                                          15540000
      ISMAX = IS -1                                                     15550000
      WRITE(66,250)ISMAX                                                15560000
 250  FORMAT(45H TOTAL NUMBER OF MAGNETIC SUBSTATES, ISMAX = ,I3)       15570001
      IF(ISMAX.LE.ICATMX)GOTO 254                                       15580000
 252  WRITE(66,253) ICATMX                                              15590000
 253  FORMAT(28H  ERROR ISMAX EXCEEDS ICATMX,5X,9H(ICATMX =,I4,1H))     15600001
      GO TO 1111                                                        15610000
 254  CONTINUE                                                          15620000
C     PRINTOUT OF SSTART ARRAY AND SSTOP ARRAY                          15630000
      WRITE(66,622) (SSTART(I),I=1,NMAX)                                15640000
 622  FORMAT(17H SSTART ARRAY    ,20I5/17X,20I5)                        15650001
      WRITE(66,623) (SSTOP(I),I=1,NMAX)                                 15660000
 623  FORMAT(17H SSTOP  ARRAY    ,20I5/17X,20I5,//)                     15670001
      IF(SPIN(1).GT.3.6) GO TO 812                                      15680000
      LMAX(1) = SPIN(1) + 1.1                                           15690000
      IRSTA(1) = 1                                                      15700000
      IF(IEXNUM.EQ.2)GOTO 80                                            15710000
      IRSTO(1) = ISMAX                                                  15720000
      GOTO 81                                                           15730000
  80  N1 = NSTART(IP)                                                   15740000
      IRSTO(1) = SSTART(N1) - 1                                         15750000
      LMAX(2) = SPIN(N1) + 1.1                                          15760000
      IRSTA(2) = IRSTO(1) + 1                                           15770000
      IRSTO(2) = ISMAX                                                  15780000
  81  CONTINUE                                                          15790000
C     COMPUTATION OF ZETA ARRAY                                         15800000
      NZ = 0                                                            15810000
      DO 130 K=1,IEXNUM                                                 15820000
      N1 = 1                                                            15830000
      IF(K.EQ.1)GOTO 105                                                15840000
      N1 = NSTART(IP)                                                   15850000
 105  IF(SPIN(N1).EQ.0.)GOTO 131                                        15860000
      IR1 = IRSTA(K)                                                    15870000
      IR2 = IRSTO(K)                                                    15880000
C     IR - LOOP FOR GROUND STATE SPIN .NE.0                             15890000
      DO 132 IR=IR1,IR2                                                 15900000
      N = CAT(IR,1)                                                     15910000
      CALL LSLOOP(IR,N,NZ)                                              15920000
 133  CONTINUE                                                          15930000
 132  CONTINUE                                                          15940000
      GOTO 130                                                          15950000
 131  IF(K.EQ.2)GOTO 138                                                15960000
      N1 = 1                                                            15970000
      N2 = NMAX                                                         15980000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   15990000
      GOTO 134                                                          16000000
 138  N1 = NSTART(IP)                                                   16010000
      N2 = NMAX                                                         16020000
C     IR - LOOP FOR GROUND STATE SPIN .EQ.0                             16030000
 134  DO 135 N=N1,N2                                                    16040000
      IR = SSTART(N) - 1                                                16050000
 136  IR = IR + 1                                                       16060000
      CALL LSLOOP(IR,N,NZ)                                              16070000
 137  IF(CAT(IR,3).LT.-0.1)GOTO 136                                     16080000
 135  CONTINUE                                                          16090000
 130  CONTINUE                                                          16100000
 596  WRITE(66,36)NZ                                                    16110000
  36  FORMAT(40H NUMBER OF ELEMENTS IN ZETA-ARRAY IS  = ,I5)            16120001
      IF ( NZ.GT.NZMAX ) GOTO 820                                       16130000
 597  WRITE(66,42) ETA                                                  16140000
  42  FORMAT(7H ETA = ,F6.2)                                            16150001
C     PRINTOUT OF LEVEL SCHEME                                          16160000
      WRITE(66,54)                                                      16170000
  54  FORMAT(13H1LEVEL SCHEME)                                          16180000
      WRITE(66,59)                                                      16190000
  59  FORMAT (48H   INDEX   SPIN      EN(MEV)     ETA           /)      16200001
      DO 62 IG1=1,NGMAX                                                 16210000
      IG = NGMAX + 1 - IG1                                              16220000
      WRITE(66,63) IG                                                   16230000
  63  FORMAT(6H GROUP,I3/)                                              16240001
      NG = NSTOP(IG) - NSTART(IG) + 1                                   16250000
      DO 64 I1=1,NG                                                     16260000
      N = NSTOP(IG) + 1 - I1                                            16270000
      WRITE(66,61) N,SPIN(N),EN(N),ETAN(N)                              16280000
  61  FORMAT (I6,F9.1,F13.5,F13.4)                                      16290000
  64  CONTINUE                                                          16300000
  62  CONTINUE                                                          16310000
      RETURN                                                            16320000
 812  WRITE(66,813)                                                     16330000
 813  FORMAT(37H ERROR- GROUND STATE SPIN EXCEEDS 7/2)                  16340001
      ERR = .TRUE.                                                      16350000
      RETURN                                                            16360000
 820  WRITE(66,821) NZMAX                                               16370000
 821  FORMAT(57H ERROR  -  NUMBER OF ELEMENTS IN ZETA ARRAY EXCEEDS NZMA16380001
     1X,5X,8H(NZMAX =,I6,1H))                                           16390001
1111  ERR = .TRUE.                                                      16400000
      RETURN                                                            16410000
      END                                                               16420000
      SUBROUTINE PR2                                                    16430000
C                                                                       16440000
C     THIS ROUTINE COMPUTES RANGE AND STEP WIDTH OF INTEGRATION         16450000
C                                                                       16460000
      INTEGER OUXI,OUPSI                                                16470000
      LOGICAL ERR                                                       16480000
      COMMON/EROR/ERR                                                   16490000
      COMMON/RPST/THETA                                                 16500000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   16510000
      COMMON/PS/DISTA,VINF                                              16520000
      COMMON/P/XIM                                                      16530000
      COMMON/P2I/UP,DW,ISTEP,D2W                                        16540000
      COMMON/RP/OUXI,OUPSI,NCM,EMMAX1                                   16550000
      COMMON/P2S/TCMDG(30),ZLBDG(30),R3(30),R4(30),EPP(30),ETP(30)      16560000
      COMMON/RPI/IT                                                     16570000
      COMMON /PIS/ XI(30,30)                                            16580000
      COMMON/RPIS/XIMAX                                                 16590000
      COMMON/P2IS/EPS,EROOT                                             16600000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          16610000
      COMMON/ALL/NMAX,NDIM,NCORR                                        16620000
      COMMON/P2DI/ACC10                                                 16630000
      COMMON/P2IQ/COT1,COT2                                             16640000
      COMMON/RS/NMAXIN,SIGTOT(30),ACCIN,PIN(30),VA,DVA,VALO,VAUP        16650000
C                                                                       16660000
C     DETERMINATION OF THE LARGEST XI VALUE IN XI MATRIX                16670000
 452  XIM = 0.0                                                         16680000
      DO 25 N = 1,NMAX                                                  16690000
      DO 26 M = 1,NMAX                                                  16700000
      IF(XI(N,M).GT.XIMAX)GO TO 26                                      16710000
      IF(XI(N,M).LE.XIM)GO TO 26                                        16720000
      XIM = XI(N,M)                                                     16730000
  26  CONTINUE                                                          16740000
  25  CONTINUE                                                          16750000
      WRITE(66,300)XIM                                                  16760000
 300  FORMAT(7H XIM = ,F10.4)                                           16770001
      IF(TLBDG.EQ.0.0.AND.THETA.NE.0.0) GO TO 446                       16780000
C     TRANSITION FROM LAB TO CM COORDINATE SYSTEM                       16790000
      CALL CMLAB(A1,A2,EP,EN,NMAXIN,TLBDG,TCMDG,ZLBDG,R3,R4,EPP,ETP)    16800000
      IF(ERR) GO TO 1111                                                16810000
      THETA=TCMDG(NCM)                                                  16820000
      WRITE(66,781) THETA                                               16830000
 781  FORMAT(29H CM SCATTERING ANGLE USED IS ,F20.15,8H DEGREES)        16840001
C     RANGE AND STEP WIDTH OF THE INTEGRATION                           16850000
 446  TRAD=THETA/57.295779                                              16860000
      STR = SIN(TRAD/2.0)                                               16870000
      EPS = 1.0/STR                                                     16880000
      EROOT = SQRT(EPS*EPS-1.)                                          16890000
      COT1 = COS(TRAD/2.0)*EPS                                          16900000
      COT2 = COT1*COT1                                                  16910000
      ACC10=ACCUR/10.0                                                  16920000
      UP=ALOG(1.0/(EPS*SQRT(ACCUR)))                                    16930000
      DW=40.0*(ACCUR**0.2)/(10.0+48.0*XIM+16.0*XIM*EPS)                 16940000
      ISTEP=UP/(DW*8.)+1.                                               16950000
      ISTEP=ISTEP*8                                                     16960000
      DW=UP/(FLOAT(ISTEP)-0.25)                                         16970000
      UP=DW*FLOAT(ISTEP)                                                16980000
      WRITE(66,202)EPS,UP,ISTEP                                         16990000
 202  FORMAT(7H EPS = ,F20.15,/                                         17000001
     128H RANGE OF INTEGRATION, UP = ,F6.2 /                            17010001
     236H ESTIMATED NUMBER OF STEPS, ISTEP = ,I4)                       17020001
      D2W = DW + DW                                                     17030000
      WRITE(66,251)D2W                                                  17040000
 251  FORMAT(27H INITIAL STEP WIDTH, D2W = ,F8.5)                       17050001
      RETURN                                                            17060000
1111  ERR =.TRUE.                                                       17070000
      RETURN                                                            17080000
      END                                                               17090000
      SUBROUTINE Q(W)                                                   17100000
C                                                                       17110000
C     THIS ROUTINE COMPUTES Q-FUNCTIONS                                 17120000
C                                                                       17130000
      IMPLICIT COMPLEX (A)                                              17140000
      INTEGER SSTART,SSTOP                                              17150000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       17160000
     1SSTART(31),SSTOP(30)                                              17170000
      COMMON/RPIS/XIMAX                                                 17180000
      COMPLEX CI,EX,PE(12,7),DEN7,DEN8,DEN9,DEN10,DEN11,DEN12           17190000
      COMPLEX CQU1,CQU2,CQU3,CQU4,CQU5,CQU6,CQU7,CQU8,CQU9,CQU10,CQU11, 17200000
     1CQU12                                                             17210000
      COMMON/P2IS/EPS,EROOT                                             17220000
      COMMON/PIS/ XI(30,30)                                             17230000
      COMMON/ALL/NMAX,NDIM,NCORR                                        17240000
      COMMON/CMPQ1/CQU1(7,30,30),CQU2(7,30,30),CQU3(7,30,30)            17250000
      COMMON/CMPQ2/CQU4(7,30,30),CQU5(7,30,30),CQU6(7,30,30)            17260000
      COMMON/CMPQ3/CQU7(7,30,30),CQU8(7,30,30),CQU9(7,30,30)            17270000
      COMMON/CMPQ4/CQU10(7,30,30),CQU11(7,30,30),CQU12(7,30,30)         17280000
      COMMON/P2IQ/COT1,COT2                                             17290000
      COMMON/QQM/B2,B4,B6,B8,B10                                        17300000
      COMMON/CQQM/A2,A4,A2B2,A6,A2B4,A4B2,A8,A2B6,A4B4,A6B2,A10,A2B8,   17310000
     1A4B6,A6B4,A8B2,A1B2,DEN7,DEN8,DEN9,DEN10,DEN11,DEN12              17320000
      COMMON/HYP/COSHY,SINHY                                            17330000
      COMMON/BLOCK1/MAGEXC                                              17340000
      COMMON/WOLLER/QUE                                                 17350000
      DATA CI/(0.0,1.0)/                                                17360000
C                                                                       17370000
      EW=EXP(W)                                                         17380000
      COSHY=0.5*(EW+1.0/EW)                                             17390000
      SINHY=0.5*(EW-1.0/EW)                                             17400000
      DEN=EPS*COSHY+1.0                                                 17410000
      DEN1=DEN*DEN                                                      17420000
      DEN2=DEN1*DEN1                                                    17430000
      DEN3=DEN2*DEN1                                                    17440000
      DEN4=DEN2*DEN2                                                    17450000
      DEN5=DEN4*DEN1                                                    17460000
      DEN6=DEN3*DEN3                                                    17470000
      SH1=COT1*SINHY                                                    17480000
      SH2=SH1*SH1                                                       17490000
      SH3=SH2*SH1                                                       17500000
      SH4=SH2*SH2                                                       17510000
      SH5=SH2*SH3                                                       17520000
      SH6=SH2*SH4                                                       17530000
      CH1=COSHY+EPS                                                     17540000
      CH2=CH1*CH1                                                       17550000
      CH3=CH2*CH1                                                       17560000
      CH4=CH2*CH2                                                       17570000
      CH5=CH2*CH3                                                       17580000
      CH6=CH3*CH3                                                       17590000
C ********************* E1 POLARISATION ******************************  17600000
      POL=1.-QUE/DEN                                                    17610000
C ********************************************************************  17620000
      IF(MAGEXC.EQ.1) CALL QM                                           17630000
      DO 400 I1=1,LAMMAX                                                17640000
      LAM = LAMDA(I1)                                                   17650000
      GOTO(11,12,13,14,15,16,17,18,19,20,21,22),LAM                     17660000
  11  PE(1,1)= 0.5       *CH1/DEN1                                      17670000
      PE(1,2)=-0.35355339*CI*SH1/DEN1                                   17680000
      GOTO 400                                                          17690000
  12  PE(2,1)= 0.75      *(2.0*CH2-SH2)/DEN2*POL                        17700000
      PE(2,2)=-1.83711730*CI*CH1*SH1/DEN2*POL                           17710000
      PE(2,3)=-0.91855865*SH2/DEN2*POL                                  17720000
      GOTO 400                                                          17730000
  13  PE(3,1)= 1.875     *CH1*(2.0*CH2-3.0*SH2)/DEN3                    17740000
      PE(3,2)=-1.62379763*CI*(4.0*CH2-SH2)*SH1/DEN3                     17750000
      PE(3,3)=-5.13489890*CH1*SH2/DEN3                                  17760000
      PE(3,4)= 2.09631373*CI*SH3/DEN3                                   17770000
      GOTO 400                                                          17780000
  14  PE(4,1)= 1.09375000*(8.0*CH4-24.0*CH2*SH2+3.0*SH4)/DEN4           17790000
      PE(4,2)=-4.89139867*CI*CH1*(4.0*CH2-3.0*SH2)*SH1/DEN4             17800000
      PE(4,3)=-3.45874113*(6.0*CH2-SH2)*SH2/DEN4                        17810000
      PE(4,4)=12.9414244 *CI*CH1*SH3/DEN4                               17820000
      PE(4,5)= 4.57548440*SH4/DEN4                                      17830000
      GOTO 400                                                          17840000
  15  PE(5,1)=1.230468*CH1*(-14.*CH2*(9.*SH2+DEN1)+30.*DEN2)/DEN5       17850000
      PE(5,2)=-1.347911*CI*SH1*(35.*CH2*(-3.*SH2+DEN1)+5.*DEN2)/DEN5    17860000
      PE(5,3)=-35.662372*SH2*CH1*(-3.*SH2+2.*DEN1)/DEN5                 17870000
      PE(5,4)=7.279552*CI*SH3*(9.*CH2-DEN1)/DEN5                        17880000
      PE(5,5)=30.884521*SH4*CH1/DEN5                                    17890000
      PE(5,6)=-9.766543*CI*SH5/DEN5                                     17900000
      GOTO 400                                                          17910000
  16  PE(6,1)=2.707031*(21.*CH2*(-CH2*(11.*SH2+4.*DEN1)+5.*DEN2)-       17920000
     1 5.*DEN3)/DEN6                                                    17930000
      PE(6,2)=-17.543567*CI*SH1*CH1*(3.*CH2*(-11.*SH2+DEN1)+5.*DEN2)/   17940000
     1 DEN6                                                             17950000
      PE(6,3)=-13.869408*SH2*(3.*CH2*(-11.*SH2+5.*DEN1)+DEN2)/DEN6      17960000
      PE(6,4)=-27.738815*CI*SH3*CH1*(-11.*SH2+8.*DEN1)/DEN6             17970000
      PE(6,5)=15.193177*SH4*(11.*CH2-DEN1)/DEN6                         17980000
      PE(6,6)=-71.262308*CI*SH5*CH1/DEN6                                17990000
      PE(6,7)=-20.571656*SH6/DEN6                                       18000000
      GOTO 400                                                          18010000
  17  PE(7,1) = (0.,0.)                                                 18020000
      PE(7,2) = -0.35355339*EROOT/DEN7                                  18030000
      GOTO 400                                                          18040000
  18  AFAC = EROOT/DEN8                                                 18050000
      PE(8,1)=(0.,0.)                                                   18060000
      PE(8,2)=-0.45927933*AFAC*(B2+A2)                                  18070000
      PE(8,3)=-0.45927933*AFAC*(B2-A2)                                  18080000
      GOTO 400                                                          18090000
  19  AFAC = EROOT/DEN9                                                 18100000
      PE(9,1)=(0.,0.)                                                   18110000
      PE(9,2)=-0.13531647*AFAC*(5.*B4+6.*A2B2+5.*A4)                    18120000
      PE(9,3)=-0.85581650*AFAC*(B4-A4)                                  18130000
      PE(9,4)=-0.52407843*AFAC*(B2-A2)**2                               18140000
      GOTO 400                                                          18150000
  20  AFAC = EROOT/DEN10                                                18160000
      PE(10,1)=(0.,0.)                                                  18170000
      PE(10,2)=-.15285621*AFAC*(7.*B6+9.*A2B4+9.*A4B2+7.*A6)            18180000
      PE(10,3)=-.21617132*AFAC*(7.*B6+3.*A2B4-3.*A4B2-7.*A6)            18190000
      PE(10,4)=-1.21325855*AFAC*(B6-A2B4-A4B2+A6)                       18200000
      PE(10,5)=-.57193557*AFAC*(B2-A2)**3                               18210000
      GOTO 400                                                          18220000
  21  AFAC = EROOT/DEN11                                                18230000
      PE(11,1)=(0.,0.)                                                  18240000
      PE(11,2)=-0.08424444*AFAC*(21.*B8+28.*A2B6+30.*A4B4+28.*A6B2      18250000
     1+21.*A8)                                                          18260000
      PE(11,3)=-0.89155931*AFAC*(3.*B8+2.*A2B6-2.*A6B2-3.*A8)           18270000
      PE(11,4)=-0.27298317*AFAC*(9.*B8-4.*A2B6-10.*A4B4-4.*A6B2+9.*A8)  18280000
      PE(11,5)=-1.54422603*AFAC*(B8-2.*A2B6+2.*A6B2-A8)                 18290000
      PE(11,6)=-0.61040893*AFAC*(B2-A2)**4                              18300000
      GOTO 400                                                          18310000
  22  AFAC = EROOT/DEN12                                                18320000
      PE(12,1)=(0.,0.)                                                  18330000
      PE(12,2)=-0.09137275*AFAC*(33.*B10+45.*A2B8+50.*A4B6+50.*A6B4     18340000
     1+45.*A8B2+33.*A10)                                                18350000
      PE(12,3)=-0.14447300*AFAC*(33.*B10+27.*A2B8+10.*A4B6-10.*A6B4     18360000
     1-27.*A8B2-33.*A10)                                                18370000
      PE(12,4)=-0.43341900*AFAC*(11.*B10-A2B8-10.*A4B6-10.*A6B4-A8B2    18380000
     1+11.*A10)                                                         18390000
      PE(12,5)=-0.31652448*AFAC*(11.*B10-15.*A2B8-10.*A4B6+10.*A6B4     18400000
     1+15.*A8B2-11.*A10)                                                18410000
      PE(12,6)=-1.85578928*AFAC*(B10-3.*A2B8+2.*A4B6+2.*A6B4-3.*A8B2    18420000
     1+A10)                                                             18430000
      PE(12,7)=-0.64286427*AFAC*(B2-A2)**5                              18440000
 400  CONTINUE                                                          18450000
      RALFA=EPS*SINHY+W                                                 18460000
      DO 30 I1=1,LAMMAX                                                 18470000
      LAM = LAMDA(I1)                                                   18480000
      LA = LAM                                                          18490000
      IF(LAM.GT.6) LAM=LAM-6                                            18500000
      DO 31 N=1,NMAX                                                    18510000
      LD = LDNUM(LA,N)                                                  18520000
      IF(LD.EQ.0) GOTO 31                                               18530000
      DO 32 I2=1,LD                                                     18540000
      M = LEAD(N,I2,LA)                                                 18550000
      X = XI(N,M)                                                       18560000
CA    IF(ABS(X).GT.XIMAX)GOTO 32                                        18570000
      EX = COS(X*RALFA) + CI*SIN(X*RALFA)                               18580000
      MYMAX = LAM + 1                                                   18590000
      IF(N.EQ.M)GOTO 33                                                 18600000
      DO 34 MY=1,MYMAX                                                  18610000
      GOTO(41,42,43,44,45,46,141,142,143,144,145,146),LA                18620000
  41  CQU1(MY,N,M) = PE(LA,MY)*EX                                       18630000
      CQU1(MY,M,N) = PE(LA,MY)/EX                                       18640000
      GOTO 34                                                           18650000
  42  CQU2(MY,N,M) = PE(LA,MY)*EX                                       18660000
      CQU2(MY,M,N) = PE(LA,MY)/EX                                       18670000
      GOTO 34                                                           18680000
  43  CQU3(MY,N,M) = PE(LA,MY)*EX                                       18690000
      CQU3(MY,M,N) = PE(LA,MY)/EX                                       18700000
      GOTO 34                                                           18710000
  44  CQU4(MY,N,M) = PE(LA,MY)*EX                                       18720000
      CQU4(MY,M,N) = PE(LA,MY)/EX                                       18730000
      GOTO 34                                                           18740000
  45  CQU5(MY,N,M) = PE(LA,MY)*EX                                       18750000
      CQU5(MY,M,N) = PE(LA,MY)/EX                                       18760000
      GOTO 34                                                           18770000
  46  CQU6(MY,N,M) = PE(LA,MY)*EX                                       18780000
      CQU6(MY,M,N) = PE(LA,MY)/EX                                       18790000
      GOTO 34                                                           18800000
 141  CQU7(MY,N,M) = PE(LA,MY)*EX                                       18810000
      CQU7(MY,M,N) = PE(LA,MY)/EX                                       18820000
      GOTO 34                                                           18830000
 142  CQU8(MY,N,M) = PE(LA,MY)*EX                                       18840000
      CQU8(MY,M,N) = PE(LA,MY)/EX                                       18850000
      GOTO 34                                                           18860000
 143  CQU9(MY,N,M) = PE(LA,MY)*EX                                       18870000
      CQU9(MY,M,N) = PE(LA,MY)/EX                                       18880000
      GOTO 34                                                           18890000
 144  CQU10(MY,N,M)= PE(LA,MY)*EX                                       18900000
      CQU10(MY,M,N)= PE(LA,MY)/EX                                       18910000
      GOTO 34                                                           18920000
 145  CQU11(MY,N,M)= PE(LA,MY)*EX                                       18930000
      CQU11(MY,M,N)= PE(LA,MY)/EX                                       18940000
      GOTO 34                                                           18950000
 146  CQU12(MY,N,M)= PE(LA,MY)*EX                                       18960000
      CQU12(MY,M,N)= PE(LA,MY)/EX                                       18970000
  34  CONTINUE                                                          18980000
      GOTO 32                                                           18990000
  33  DO 35 MY=1,MYMAX                                                  19000000
      GOTO(51,52,53,54,55,56,57,58,59,60,61,62),LA                      19010000
  51  CQU1(MY,N,M) = PE(LA,MY)                                          19020000
      GOTO 35                                                           19030000
  52  CQU2(MY,N,M) = PE(LA,MY)                                          19040000
      GOTO 35                                                           19050000
  53  CQU3(MY,N,M) = PE(LA,MY)                                          19060000
      GOTO 35                                                           19070000
  54  CQU4(MY,N,M) = PE(LA,MY)                                          19080000
      GOTO 35                                                           19090000
  55  CQU5(MY,N,M) = PE(LA,MY)                                          19100000
      GOTO 35                                                           19110000
  56  CQU6(MY,N,M) = PE(LA,MY)                                          19120000
      GOTO 35                                                           19130000
  57  CQU7(MY,N,M) = PE(LA,MY)                                          19140000
      GOTO 35                                                           19150000
  58  CQU8(MY,N,M) = PE(LA,MY)                                          19160000
      GOTO 35                                                           19170000
  59  CQU9(MY,N,M) = PE(LA,MY)                                          19180000
      GOTO 35                                                           19190000
  60  CQU10(MY,N,M)= PE(LA,MY)                                          19200000
      GOTO 35                                                           19210000
  61  CQU11(MY,N,M)= PE(LA,MY)                                          19220000
      GOTO 35                                                           19230000
  62  CQU12(MY,N,M)= PE(LA,MY)                                          19240000
  35  CONTINUE                                                          19250000
  32  CONTINUE                                                          19260000
  31  CONTINUE                                                          19270000
  30  CONTINUE                                                          19280000
      RETURN                                                            19290000
      END                                                               19300000
      SUBROUTINE QM                                                     19310000
C                                                                       19320000
C     THIS ROUTINE IS PART OF SUBROUTINE Q(W)                           19330000
C                                                                       19340000
      IMPLICIT COMPLEX (A)                                              19350000
      COMPLEX DEN7,DEN8,DEN9,DEN10,DEN11,DEN12,CI                       19360000
      COMMON/QQM/B2,B4,B6,B8,B10                                        19370000
      COMMON/CQQM/A2,A4,A2B2,A6,A2B4,A4B2,A8,A2B6,A4B4,A6B2,A10,A2B8,   19380000
     1A4B6,A6B4,A8B2,A1B2,DEN7,DEN8,DEN9,DEN10,DEN11,DEN12              19390000
      COMMON/P2IS/EPS,EROOT                                             19400000
      COMMON/HYP/COSHY,SINHY                                            19410000
      DATA CI/(0.,1.)/                                                  19420000
C                                                                       19430000
      A = COSHY + EPS + CI*EROOT*SINHY                                  19440000
      B = EPS*COSHY + 1.                                                19450000
      B2 = B*B                                                          19460000
      A2 = A*A                                                          19470000
      B4 = B2*B2                                                        19480000
      A4 = A2*A2                                                        19490000
      A2B2 = A2*B2                                                      19500000
      B6 = B4*B2                                                        19510000
      A6 = A4*A2                                                        19520000
      A2B4 = A2B2 * B2                                                  19530000
      A4B2 = A4 * B2                                                    19540000
      B8 = B6 * B2                                                      19550000
      A8 = A6 * A2                                                      19560000
      A2B6 = A2B4 * B2                                                  19570000
      A4B4 = A4B2 * B2                                                  19580000
      A6B2 = A6 * B2                                                    19590000
      B10 = B8 * B2                                                     19600000
      A10 = A8 * A2                                                     19610000
      A2B8 = A2B6 * B2                                                  19620000
      A4B6 = A4B4 * B2                                                  19630000
      A6B4 = A6B2 * B2                                                  19640000
      A8B2 = A8 * B2                                                    19650000
      A1B2 = A * B2                                                     19660000
      DEN7 = B2                                                         19670000
      DEN8 = DEN7 * A1B2                                                19680000
      DEN9 = DEN8 * A1B2                                                19690000
      DEN10 = DEN9 * A1B2                                               19700000
      DEN11 = DEN10 * A1B2                                              19710000
      DEN12 = DEN11 * A1B2                                              19720000
      RETURN                                                            19730000
      END                                                               19740000
      COMPLEX FUNCTION R(K,KAPPA,THETAN,TGAMMA,PGAMMA)                  19750000
C                                                                       19760000
C     THIS ROUTINE COMPUTES RELATIVISTIC CORRECTIONS TO THE             19770000
C     ANGULAR DISTRIBUTION TENSORS ANG3(N,K,KAPPA)                      19780000
C                                                                       19790000
      COMPLEX Y,YKK,S,S1,S2                                             19800000
      R = (0.,0.)                                                       19810000
      YKK = Y(K,KAPPA,TGAMMA,PGAMMA)                                    19820000
C     IF(YKK.EQ.(0.,0.)) RETURN                                         19830000
      YR=REAL(YKK)                                                      19840000
      YI=AIMAG(YKK)                                                     19850000
      IF(YR.EQ.0.0.AND.YI.EQ.0.0) RETURN                                19860000
      S = (0.,0.)                                                       19870000
      A1 = K                                                            19880000
      B1 = KAPPA                                                        19890000
      A2M = K-1                                                         19900000
      A2P = K+1                                                         19910000
      FAC1 = SQRT(A1)*A2M                                               19920000
      FAC2 = SQRT(A2P)*(A2P+1.)                                         19930000
      KAPPAP = KAPPA-1                                                  19940000
 100  B2 = -KAPPAP                                                      19950000
      MY = KAPPAP-KAPPA                                                 19960000
      B3 = MY                                                           19970000
      S1 = (0.,0.)                                                      19980000
      S2 = (0.,0.)                                                      19990000
      IF(K.EQ.0.OR.K.EQ.1)GOTO 200                                      20000000
      IF(IABS(KAPPAP).GT.K-1)GOTO 200                                   20010000
      S1=FAC1*THREEJ(A1,B1,A2M,B2,1.,B3)*Y(K-1,KAPPAP,TGAMMA,PGAMMA)    20020000
 200  IF(IABS(KAPPAP).GT.K+1)GOTO 300                                   20030000
      S2=FAC2*THREEJ(A1,B1,A2P,B2,1.,B3)*Y(K+1,KAPPAP,TGAMMA,PGAMMA)    20040000
 300  S=S+(S1+S2)*Y(1,MY,THETAN,0.)*(-1)**(K+KAPPAP+1)                  20050000
      IF(KAPPAP.GE.KAPPA+1)GOTO 400                                     20060000
      KAPPAP = KAPPAP + 1                                               20070000
      GOTO 100                                                          20080000
 400  R = 2.0466534*S/YKK                                               20090000
      RETURN                                                            20100000
      END                                                               20110000
      SUBROUTINE READER                                                 20120000
C                                                                       20130000
C     THIS ROUTINE READS THE INPUT DATA                                 20140000
C     IT CHECKS THE INPUT                                               20150000
C                                                                       20160000
      LOGICAL ERR                                                       20170000
      INTEGER SSTART,SSTOP                                              20180000
      COMMON/EUL/ALPHA,BETA,GAMMA,THETAC,PHIC                           20190000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  20200000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       20210000
     1SSTART(31),SSTOP(30)                                              20220000
      COMMON/EMR/QZERO,ALPHA0,ALPHA2,QUINT2,QUINT4,QUINT6               20230000
      COMMON/EROR/ERR                                                   20240000
      INTEGER OUAMP,OUPROW                                              20250000
      INTEGER OUXI,OUPSI                                                20260000
      INTEGER OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5                 20270000
      REAL ME                                                           20280000
      COMMON/AR/NANGLE,THI,TLI                                          20290000
      COMMON/RPST/THETA                                                 20300000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   20310000
      COMMON/RI/OUAMP,OUPROW,INTERV,INTIN                               20320000
      COMMON/RP/OUXI,OUPSI,NCM,EMMAX1                                   20330000
      COMMON/ARI/NTIME                                                  20340000
      COMMON/RPIS/XIMAX                                                 20350000
      COMMON/RP1M/ME(30,30,12)                                          20360000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          20370000
      COMMON/ALL/NMAX,NDIM,NCORR                                        20380000
      COMMON/RS/NMAXIN,SIGTOT(30),ACCIN,PIN(30),VA,DVA,VALO,VAUP        20390000
      COMMON/ART/OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5              20400000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       20410000
      COMMON/MR/IPURG                                                   20420000
      COMMON/MRCH/IA17,IA18,IA19                                        20430000
      COMMON/RDSTA/IPAR(30),IFAC(30)                                    20440000
      COMMON/BLOCK1/MAGEXC                                              20450000
      COMMON/GAM/TGAMMA,PGAMMA                                          20460000
      DIMENSION FINPUT(8)                                               20470000
C                                                                       20480000
C     READ IN STARTS                                                    20490000
      open (5,file='input')
      open (66,file='output')
      open (67,file='anggro')
      PRINT 102                                                         20500000
 102  FORMAT( //, 32H LIST OF NEW CARDS FOR THIS RUN. )                 20510000
 104  CONTINUE                                                          20520000
      READ(5,106) (FINPUT(I), I=1,8)                                    20530000
 106  FORMAT( 8F10.5 )                                                  20540000
      IF( FINPUT(1) .EQ. 0. ) GO TO 500                                 20550000
C     STATEMENT 500 MEANS:  START EXECUTION OF JOB                      20560000
      IF(FINPUT(1).LE.0.)GOTO 600                                       20570000
C     STATEMENT 600 MEANS:  PURGE ALL PREVIOUS INPUT                    20580000
      PRINT 106, (FINPUT(I), I=1,6)                                     20590000
      IF( FINPUT(1) .LT. 41. ) GO TO 105                                20600000
C     CALLS EXIT IF NO MORE DATA                                        20610000
C **********************************************************************20620000
C **********************************************************************20630000
C **********************************************************************20640000
      THETA=0.0                                                         20650000
      WRITE(67,8000) THETA                                              20660000
 8000 FORMAT(F10.3)
C **********************************************************************20670000
C **********************************************************************20680000
C **********************************************************************20690000
C      CALL EXIT                                                        20700000
       STOP
 105  CONTINUE                                                          20710000
      IJUMP = IFIX( FINPUT(1) + .00001 )                                20720000
      GO TO (501,502,503,504,505,506,507,508,509,510,511,512,513,514,   20730000
     1 515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530, 20740000
     2 531,532,533,534,535,536,537,538,539,540),IJUMP                   20750000
 501  CONTINUE                                                          20760000
      NMAX = FINPUT(2)                                                  20770000
      NMAXIN = NMAX                                                     20780000
      IF(NMAX.LT.2.OR.NMAX.GT.NDIM) CALL ERROR(1)                       20790000
      GO TO 104                                                         20800000
 502  CONTINUE                                                          20810000
      NCM = FINPUT(2)                                                   20820000
      IF(NCM.GE.1.AND.NCM.LE.NDIM)GOTO 104                              20830000
      NCM = 2                                                           20840000
      WRITE(66,110)                                                     20850000
 110  FORMAT(24H PROGRAM ASSUMES NCM = 2)                               20860000
      GO TO 104                                                         20870000
 503  CONTINUE                                                          20880000
      NTIME = FINPUT(2)                                                 20890000
      GO TO 104                                                         20900000
 504  CONTINUE                                                          20910000
      XIMAX = FINPUT(2)                                                 20920000
      IF(XIMAX.LE.0..OR.XIMAX.GE.99.)CALL ERROR(2)                      20930000
      GO TO 104                                                         20940000
 505  CONTINUE                                                          20950000
      EMMAX1 = FINPUT(2)                                                20960000
      IF(EMMAX1.LT.0.)CALL ERROR(3)                                     20970000
      GO TO 104                                                         20980000
 506  CONTINUE                                                          20990000
      ACCIN=FINPUT(2)                                                   21000000
      QPAR=FINPUT(3)                                                    21010000
      IF(ACCIN.LE.0.)CALL ERROR(4)                                      21020000
      IF(ACCIN.GT.0.0001)GOTO 115                                       21030000
      GOTO 104                                                          21040000
 115  ACCIN = 0.0001                                                    21050000
      WRITE(66,116)                                                     21060000
 116  FORMAT(32HPROGRAM ASSUMES  ACCUR = 0.0001,/)                      21070000
      GO TO 104                                                         21080000
 507  CONTINUE                                                          21090000
      OUXI = FINPUT(2)                                                  21100000
      GO TO 104                                                         21110000
 508  CONTINUE                                                          21120000
      OUPSI = FINPUT(2)                                                 21130000
      GO TO 104                                                         21140000
 509  CONTINUE                                                          21150000
      OUAMP = FINPUT(2)                                                 21160000
      GO TO 104                                                         21170000
 510  CONTINUE                                                          21180000
      OUPROW = FINPUT(2)                                                21190000
      GO TO 104                                                         21200000
 511  CONTINUE                                                          21210000
      OUANG0 = FINPUT(2)                                                21220000
      GO TO 104                                                         21230000
 512  CONTINUE                                                          21240000
      OUANG1 = FINPUT(2)                                                21250000
      GO TO 104                                                         21260000
 513  CONTINUE                                                          21270000
      OUANG2 = FINPUT(2)                                                21280000
      GO TO 104                                                         21290000
 514  CONTINUE                                                          21300000
      OUANG3 = FINPUT(2)                                                21310000
      GO TO 104                                                         21320000
 515  CONTINUE                                                          21330000
      NCORR = FINPUT(2)                                                 21340000
      GO TO 104                                                         21350000
 516  CONTINUE                                                          21360000
      INTIN=FINPUT(2)                                                   21370000
      IF(INTIN.GE.1)GOTO 104                                            21380000
      INTIN = 1                                                         21390000
      WRITE(66,120)                                                     21400000
 120  FORMAT(28H PROGRAM ASSUMES  INTERV = 1)                           21410000
      GO TO 104                                                         21420000
 517  CONTINUE                                                          21430000
      IA17 = 1                                                          21440000
      Z1 = FINPUT(2)                                                    21450000
      A1 = FINPUT(3)                                                    21460000
      IF(Z1.LE.0..OR.A1.LE.0.)CALL ERROR(5)                             21470000
      IF(Z1.GT.A1)CALL ERROR(6)                                         21480000
      GO TO 104                                                         21490000
 518  CONTINUE                                                          21500000
      IA18 = 1                                                          21510000
      Z2 = FINPUT(2)                                                    21520000
      A2 = FINPUT(3)                                                    21530000
      IF(Z2.LE.0..OR.A2.LE.0.)CALL ERROR(5)                             21540000
      IF(Z2.GT.A2)CALL ERROR(6)                                         21550000
      GOTO 104                                                          21560000
 519  CONTINUE                                                          21570000
      IA19 = 1                                                          21580000
      EP = FINPUT(2)                                                    21590000
      IF(EP.LE.0.)CALL ERROR(7)                                         21600000
      GO TO 104                                                         21610000
 520  CONTINUE                                                          21620000
      TLI = FINPUT(2)                                                   21630000
      IF(TLI.LT.0..OR.TLI.GT.180.)CALL ERROR(8)                         21640000
      GO TO 104                                                         21650000
 521  CONTINUE                                                          21660000
      THI = FINPUT(2)                                                   21670000
      IF(THI.LT.0..OR.THI.GT.180.)CALL ERROR(8)                         21680000
      GO TO 104                                                         21690000
 522  CONTINUE                                                          21700000
      N = FINPUT(2)                                                     21710000
      IF(N.LT.1.OR.N.GT.NDIM) CALL ERROR(9)                             21720000
      SPIN(N) = FINPUT(3)                                               21730000
      EN(N) = FINPUT(4)                                                 21740000
      IPAR(N) = FINPUT(5)                                               21750000
      IF(SPIN(N).LT.0.)CALL ERROR(10)                                   21760000
      IF(EN(N).LT.0.)CALL ERROR(11)                                     21770000
      IF(IPAR(N).NE.1..AND.IPAR(N).NE.-1.)CALL ERROR(12)                21780000
      GO TO 104                                                         21790000
 523  CONTINUE                                                          21800000
      N = FINPUT(2)                                                     21810000
      M = FINPUT(3)                                                     21820000
      LAM=FINPUT(5)                                                     21830000
      IF(LAM.EQ.0) LAM=2                                                21840000
      IF(N.LT.1.OR.N.GT.NDIM)CALL ERROR(9)                              21850000
      IF(M.LT.1.OR.M.GT.NDIM)CALL ERROR(9)                              21860000
      IF(LAM.LT.1.OR.LAM.GT.6)CALL ERROR(13)                            21870000
      ME(N,M,LAM)=FINPUT(4)                                             21880000
      IF(LAM.EQ.LAMDA(1).OR.LAM.EQ.LAMDA(2).OR.LAM.EQ.LAMDA(3).OR.LAM.EQ21890000
     1.LAMDA(4).OR.LAM.EQ.LAMDA(5).OR.LAM.EQ.LAMDA(6).OR.LAM.EQ.LAMDA(7)21900000
     2.OR.LAM.EQ.LAMDA(8).OR.LAM.EQ.LAMDA(9).OR.LAM.EQ.LAMDA(10).OR.    21910000
     3LAM.EQ.LAMDA(11).OR.LAM.EQ.LAMDA(12))GOTO 104                     21920000
      LAMMAX = LAMMAX + 1                                               21930000
      LAMDA(LAMMAX) = LAM                                               21940000
      GOTO 104                                                          21950000
 524  CONTINUE                                                          21960000
      MAGEXC = 1                                                        21970000
      N = FINPUT(2)                                                     21980000
      M = FINPUT(3)                                                     21990000
      LA = FINPUT(5)                                                    22000000
      IF(LA.EQ.0) LA=1                                                  22010000
      LAM = LA + 6                                                      22020000
      IF(N.LT.1.OR.N.GT.NDIM) CALL ERROR(9)                             22030000
      IF(M.LT.1.OR.M.GT.NDIM) CALL ERROR(9)                             22040000
      IF(LA.LT.1.OR.LA.GT.6) CALL ERROR(13)                             22050000
      ME(N,M,LAM)=FINPUT(4)                                             22060000
      IF(LAM.EQ.LAMDA(1).OR.LAM.EQ.LAMDA(2).OR.LAM.EQ.LAMDA(3).OR.LAM.EQ22070000
     1.LAMDA(4).OR.LAM.EQ.LAMDA(5).OR.LAM.EQ.LAMDA(6).OR.LAM.EQ.LAMDA(7)22080000
     2.OR.LAM.EQ.LAMDA(8).OR.LAM.EQ.LAMDA(9).OR.LAM.EQ.LAMDA(10).OR.    22090000
     3LAM.EQ.LAMDA(11).OR.LAM.EQ.LAMDA(12))GOTO 104                     22100000
      LAMMAX = LAMMAX + 1                                               22110000
      LAMDA(LAMMAX) = LAM                                               22120000
      GOTO 104                                                          22130000
 525  CONTINUE                                                          22140000
      QZERO = FINPUT(2)                                                 22150000
      ALPHA0 = FINPUT(3)                                                22160000
      ALPHA2 = FINPUT(4)                                                22170000
      QUINT2 = FINPUT(5)                                                22180000
      IF(QZERO.NE.0.0) QUINT2=0.315391*QZERO                            22190000
      QUINT4 = FINPUT(6)                                                22200000
      QUINT6 = FINPUT(7)                                                22210000
      CALL MATROT                                                       22220000
      GO TO 104                                                         22230000
 526  CONTINUE                                                          22240000
 527  CONTINUE                                                          22250000
 528  CONTINUE                                                          22260000
 529  CONTINUE                                                          22270000
 530  CONTINUE                                                          22280000
 531  CONTINUE                                                          22290000
      GO TO 104                                                         22300000
 532  CONTINUE                                                          22310000
      GO TO 104                                                         22320000
 533  CONTINUE                                                          22330000
      NGMAX = FINPUT(2)                                                 22340000
      IF(NGMAX.LT.1.OR.NGMAX.GT.10)CALL ERROR(14)                       22350000
      GOTO 104                                                          22360000
 534  CONTINUE                                                          22370000
      I = FINPUT(2)                                                     22380000
      IF(I.LT.1.OR.I.GT.10)CALL ERROR(15)                               22390000
      NSTART(I) = FINPUT(3)                                             22400000
      NSTOP(I) = FINPUT(4)                                              22410000
      EMMAX(I) = FINPUT(5)                                              22420000
      IF(NSTART(I).LT.1.OR.NSTART(I).GT.NDIM)CALL ERROR(16)             22430000
      IF(NSTOP(I).LT.1.OR.NSTOP(I).GT.NDIM)CALL ERROR(16)               22440000
      IF(NSTOP(I).LE.NSTART(I))CALL ERROR(17)                           22450000
      IF(EMMAX(I).LT.0.)CALL ERROR(18)                                  22460000
      IF(NSTOP(I)-NSTART(I).GT.10) CALL ERROR(20)                       22470000
      GOTO 104                                                          22480000
 535  CONTINUE                                                          22490000
      I1 = FINPUT(2)                                                    22500000
      I2 = FINPUT(3)                                                    22510000
      IF(I1.LT.1.OR.I1.GT.10)CALL ERROR(15)                             22520000
      IF(I2.LT.1.OR.I2.GT.10)CALL ERROR(15)                             22530000
      MISTER(I1,I2) = FINPUT(4)                                         22540000
      GO TO 104                                                         22550000
 536  CONTINUE                                                          22560000
      I = FINPUT(2)                                                     22570000
      IF(I.LT.1.OR.I.GT.10)CALL ERROR(15)                               22580000
      IEXCIT(I) = FINPUT(3)                                             22590000
      IF(IEXCIT(I).NE.1.AND.IEXCIT(I).NE.2)CALL ERROR(19)               22600000
      GOTO 104                                                          22610000
 537  CONTINUE                                                          22620000
      THETAC = FINPUT(2)                                                22630000
      PHIC = FINPUT(3)                                                  22640000
      OUANG4 = 1                                                        22650000
      IF(THETAC.LT.0..OR.THETAC.GT.180.)CALL ERROR(21)                  22660000
      IF(PHIC.LT.0..OR.PHIC.GT.360.)CALL ERROR(22)                      22670000
      GOTO 104                                                          22680000
 538  CONTINUE                                                          22690000
      TGAMMA=FINPUT(2)                                                  22700000
      PGAMMA=FINPUT(3)                                                  22710000
      OUANG5 = 1                                                        22720000
      OUANG3 = 1                                                        22730000
      GOTO 104                                                          22740000
 539  CONTINUE                                                          22750000
 540  CONTINUE                                                          22760000
      GOTO 104                                                          22770000
 500  IF(ERR)GOTO 700                                                   22780000
      CALL CHECK                                                        22790000
      IF(ERR)GOTO 700                                                   22800000
      CALL START                                                        22810000
      RETURN                                                            22820000
 600  IPURG = 1                                                         22830000
      RETURN                                                            22840000
 700  WRITE(66,900)                                                     22850000
      RETURN                                                            22860000
 900  FORMAT(21H EXECUTION TERMINATED)                                  22870001
      END                                                               22880000
      SUBROUTINE SIGM                                                   22890000
C                                                                       22900000
C     THIS ROUTINE COMPUTES TOTOAL CROSS SECTIONS AND TOTAL ANGULAR     22910000
C     DISTRIBUTION TENSORS                                              22920000
C                                                                       22930000
      COMPLEX ANG3R,ANG3RT                                              22940000
      LOGICAL ERR                                                       22950000
      COMMON/EUL/ALPHA,BETA,GAMMA,THETAC,PHIC                           22960000
      COMMON/EROR/ERR                                                   22970000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  22980000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       22990000
      COMMON/RPST/THETA                                                 23000000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   23010000
      COMMON/PIS/ XI(30,30)                                             23020000
      COMMON/IS/P(30)                                                   23030000
      COMMON/ARS/SIMP                                                   23040000
      COMMON/RPIS/XIMAX                                                 23050000
      COMMON/P2S/TCMDG(30),ZLBDG(30),R3(30),R4(30),EPP(30),ETP(30)      23060000
      COMMON/P2IS/EPS,EROOT                                             23070000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          23080000
      COMMON/ALL/NMAX,NDIM,NCORR                                        23090000
C     COMMON/ALL/NMAX,NDIM                                              23100000
      COMMON/PS/DISTA,VINF                                              23110000
      COMMON/RS/NMAXIN,SIGTOT(30),ACCIN,PIN(30),VA,DVA,VALO,VAUP        23120000
      COMMON/AR/NANGLE,THI,TLI                                          23130000
      COMMON/SR/DTHETA,DTLBDG                                           23140000
      COMMON/STT/DTHETR,DTLBR                                           23150000
      COMMON/TESI/ANG3(30,3,5),ANG3R(30,3,5)                            23160000
      COMMON/TTOT/ANG3T(30,3,5),ANG3RT(30,3,5)                          23170000
      INTEGER OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5                 23180000
      COMMON/ART/OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5              23190000
      COMMON/SIG/DSIG(30),DSIGLB(30),ACCSIG(30),RU(30)                  23200000
      COMMON/GAM/TGAMMA,PGAMMA                                          23210000
C                                                                       23220000
C     COMPUTATION OF THE DIFFERENTIAL CROSS-SECTIONS                    23230000
      IF(TLBDG)432,433,432                                              23240000
C     HEADING FOR CM CROSS SECTIONS                                     23250000
 433  WRITE(66,434) THETA                                               23260000
 434  FORMAT(52H SCATTERING ANGLE IN CENTER OF MASS SYSTEM  THETA = ,   23270001
     1F7.2,8H DEGREES)                                                  23280001
 298  WRITE(66,510)                                                     23290000
 510  FORMAT(1X/,12H LEVEL INDEX,10X,10HEXCITATION,11X,                 23300001
     116HCM CROSS SECTION/                                              23310001
     222X,13HPROBABILITIES,9X,15HBARNS/STERADIAN//7X,1HN,18X,4HP(N),18X,23320001
     37HDSIG(N))                                                        23330001
      GO TO 297                                                         23340000
C     HEADING FOR LAB CROSS SECTIONS                                    23350000
 432  WRITE(66,436) TLBDG                                               23360000
 436  FORMAT(48H SCATTERING ANGLE IN LABORATORY SYSTEM  TLBDG = ,F7.2,  23370000
     1 8H DEGREES)                                                      23380000
 261  WRITE(66,471)                                                     23390000
 471  FORMAT(6H LEVEL,4X,10HSCATTERING,8X,10HEXCITATION,8X,             23400001
     19HLAB CROSS,9X,                                                   23410001
     29HENERGY OF,9X,9HERERGY OF,9X,10HLAB RECOIL,8X,                   23420001
     311HSOLID ANGLE/6H INDEX,                                          23430001
     44X,8HANGLE-CM,10X,13HPROBABILITIES,5X,7HSECTION,11X,              23440001
     59HSCATTERED,9X,6HRECOIL,                                          23450001
     63HING,9X,5HANGLE,13X,9HRATIO FOR/10X,7HDEGREES,29X,               23460001
     715HBARNS/STERADIAN,                                               23470001
     83X,14HPROJECTILE,MEV,4X,10HTARGET,MEV,8X,7HDEGREES,11X,6HRECOIL// 23480001
     93X,1HN,6X,                                                        23490001
     +8HTCMDG(N),10X,4HP(N),14X,9HDSIGLB(N),9X,6HEPP(N),12X,6HETP(N),   23500001
     *12X,8HZLBDG(N),10X,5HR4(N))                                       23510001
 297  DO 480 I=1,NGMAX                                                  23520000
      WRITE(66,481) I                                                   23530000
 481  FORMAT(6H GROUP,I3/)                                              23540001
      N1 = NSTART(I)                                                    23550000
      N2 = NSTOP(I)                                                     23560000
      DO 470 N=N1,N2                                                    23570000
      RU(N)=0.25*SQRT(EP/(EP-(1.0+A1/A2)*EN(N)))*DISTA**2*EPS**4        23580000
      DSIG(N) = RU(N)*P(N)                                              23590000
      ACCS=(2.0*SQRT(P(N))+ACCUR)*ACCUR                                 23600000
      IJP=IFIX(ALOG(1.0/ACCS)/2.302  +1.5)                              23610000
      IJS=1                                                             23620000
      IF(P(N).EQ.0.0) GO TO 22                                          23630000
      IJS=IFIX(ALOG(P(N)/ACCS)/2.302 +1.5)                              23640000
      IF(IJS.LT.1) IJS=1                                                23650000
  22  CONTINUE                                                          23660000
      IF(TLBDG) 296,295,296                                             23670000
 295  IF(IJP.GT.9) GO TO 20                                             23680000
      WRITE(66,50)N,P(N),DSIG(N)                                        23690000
  50  FORMAT (I8,6X,E19.4,5X,E19.4)                                     23700000
      GO TO 470                                                         23710000
  20  WRITE(66,55)N,P(N),DSIG(N)                                        23720000
  55  FORMAT (I8,6X,E19.4,5X,E19.4)                                     23730000
      GO TO 470                                                         23740000
 296  DSIGLB(N) = DSIG(N)*R3(N)                                         23750000
      IF(IJP.GT.9) GO TO 21                                             23760000
C     WRITE(66,60)N,TCMDG(N),P(N),DSIGLB(N),EPP(N),ZLBDG(N),R4(N)       23770000
      WRITE(66,60)N,TCMDG(N),P(N),DSIGLB(N),EPP(N),ETP(N),ZLBDG(N),R4(N)23780000
C 60  FORMAT(2XI3,13XF7.2,5XE19.4,4XE19.4,4XF8.3,12XF7.2,12XF9.5)       23790000
  60  FORMAT(1X,I3,5X,F7.2,7X,E14.4,4X,E14.4,8X,F7.2,11X,F7.2,11X,
     1F7.2,9X,F7.2)                                                     23800000
      GO TO 470                                                         23810000
  21  WRITE(66,70)N,TCMDG(N),P(N),DSIGLB(N),EPP(N),ZLBDG(N),R4(N)       23820000
  70  FORMAT(2X,I3,13X,F7.2,5X,E19.4,4X,E19.4,4X,F8.3,12X,F7.2,12X,F9.5)23830000
 470  CONTINUE                                                          23840000
 480  CONTINUE                                                          23850000
C                                                                       23860000
      IF(OUANG0) 520,523,520                                            23870000
 520  WRITE(66,521)                                                     23880000
 521  FORMAT(1H1,9X,
     149HTHE ANGULAR DISTRIBUTION TENSORS ANG0(N,KA,KAPPA))             23890000
      CALL TENTOT(1)                                                    23900000
 523  IF(OUANG1) 524,527,524                                            23910000
 524  WRITE(66,525)                                                     23920000
 525  FORMAT(1H1,9X,
     149HTHE ANGULAR DISTRIBUTION TENSORS ANG1(N,KA,KAPPA))             23930000
      CALL TENTOT(2)                                                    23940000
 527  IF(OUANG2) 528,531,528                                            23950000
 528  WRITE(66,529)                                                     23960000
 529  FORMAT(1H1,9X,
     149HTHE ANGULAR DISTRIBUTION TENSORS ANG2(N,KA,KAPPA))             23970000
      CALL TENTOT(3)                                                    23980000
 531  IF(OUANG3) 532,535,532                                            23990000
 532  WRITE(66,533)                                                     24000000
 533  FORMAT(1H1,9X,
     149HTHE ANGULAR DISTRIBUTION TENSORS ANG3(N,KA,KAPPA))             24010000
      CALL TENTOT(4)                                                    24020000
 535  CONTINUE                                                          24030000
      IF(OUANG4)536,540,536                                             24040000
 536  WRITE(66,537)                                                     24050000
 537  FORMAT(1H1,9X,
     149HTHE ANGULAR DISTRIBUTION TENSORS ANG4(N,KA,KAPPA))             24060000
      CALL TENTOT(7)                                                    24070000
      WRITE(66,539) ALPHA,BETA,GAMMA                                    24080000
 539  FORMAT(33H EULERIAN ANGLES USED:   ALPHA = ,F7.2,3X,7HBETA = ,F7.224090001
     1,3X,8HGAMMA = ,F7.2)                                              24100001
 540  IF(OUANG5) 541,545,541                                            24110000
 541  WRITE(66,542)                                                     24120000
 542  FORMAT(1H1,9X,
     150HTHE ANGULAR DISTRIBUTION TENSORS ANG3R(N,KA,KAPPA))            24130000
      WRITE(66,543) TGAMMA,PGAMMA                                       24140000
      CALL TENTOT(9)                                                    24150000
 543  FORMAT(39H DIRECTION OF GAMMA COUNTER   TGAMMA = ,F6.2,4X,        24160001
     19HPGAMMA = ,F6.2)                                                 24170001
 545  CONTINUE                                                          24180000
C                                                                       24190000
      IF(SIMP.EQ.0.0) GO TO 466                                         24200000
      PIN(1)=1.0                                                        24210000
      DO 3 N=2,NMAX                                                     24220000
      IF(P(N).GT.PIN(N)) PIN(N)=P(N)                                    24230000
   3  ACCSIG(N)=3.0*ACCIN*SQRT(PIN(N))*DISTA**2                         24240000
      IF( TLBDG.NE.0.0) GO TO 460                                       24250000
C                                                                       24260000
C      TOTAL CROSS SECTIONS FROM CM DIFF CROSS SECTIONS                 24270000
  10  DO 11 N=2,NMAX                                                    24280000
  11  SIGTOT(N)=2.0*3.1415926*DTHETR/3.0*SIMP*DSIG(N)*SIN(THETA/57.2957724290000
     19) + SIGTOT(N)                                                    24300000
      IF(OUANG3)300,350,300                                             24310000
 300  CALL TENTOT(5)                                                    24320000
 350  IF(OUANG5) 360,400,360                                            24330000
 360  CALL TENTOT(10)                                                   24340000
 400  THETA = THETA - DTHETA                                            24350000
      IF(THETA.LT.0.5*DTHETA)GOTO 462                                   24360000
      GO TO  461                                                        24370000
C                                                                       24380000
C     TOTAL CROSS SECTIONS FROM LABORATORY DIFF CROSS SECTIONS          24390000
 460  DO 816 N=1,NMAX                                                   24400000
 816  SIGTOT(N)=2.*3.1415926*DTLBR/3.*SIMP*DSIGLB(N)*                   24410000
     1SIN(TLBDG/57.295779) + SIGTOT(N)                                  24420000
      IF(OUANG3)310,320,310                                             24430000
 310  CALL TENTOT(8)                                                    24440000
 320  IF(OUANG5) 330,410,330                                            24450000
 330  CALL TENTOT(11)                                                   24460000
 410  TLBDG = TLBDG-DTLBDG                                              24470000
      IF(TLBDG.LT.THI)GOTO 462                                          24480000
      IF(TLBDG.GT.THI+0.0001)GOTO 461                                   24490000
      SIMP = 1.0                                                        24500000
      GO TO 465                                                         24510000
 461  IF (SIMP.LE.2.001) GO TO 463                                      24520000
      IF(SIMP.LE.3.001) GO TO 465                                       24530000
 464  SIMP =2.0                                                         24540000
      GO TO 465                                                         24550000
 463  SIMP =4.0                                                         24560000
 465  CONTINUE                                                          24570000
      IF(EPS.LT.10.0.OR.XI(NMAX,1).GT.XIMAX.OR.DSIG(NMAX).GT.XI(NMAX,1) 24580000
     1*EPS**3*ACCSIG(NMAX)*0.2) GO TO 110                               24590000
      IF(NMAX.EQ.1) GO TO 462                                           24600000
      GO TO 465                                                         24610000
 110  QUOT=0.0                                                          24620000
      DO 1 N=2,NMAX                                                     24630000
   1  IF(P(N)/PIN(N).GT.QUOT) QUOT=P(N)/PIN(N)                          24640000
      IF(TLBDG.NE.0.0) GO TO 109                                        24650000
      ACCUR=ACCIN*SQRT(1.0/QUOT)/EPS**3                                 24660000
      IF(ACCUR.LT.0.0000001) ACCUR=0.0000001                            24670000
      GO TO 466                                                         24680000
 109  ACCUR=ACCIN*SQRT(1.0/QUOT)*SIN(TLBDG/(2.0*57.29)) **3             24690000
      IF(ACCUR.LT.0.0000001) ACCUR=0.0000001                            24700000
      GO TO 466                                                         24710000
 462  WRITE(66,5)                                                       24720000
   5  FORMAT(1X/)                                                       24730001
      IF(TLBDG.NE.0.0) GO TO 30                                         24740000
      WRITE(66,468)                                                     24750000
 468  FORMAT(45H                TOTAL CROSS SECTIONS IN BARNS)          24760001
      GO TO 31                                                          24770000
CD30  TLBDG=2.0*57.295779* ASIN(EXP(-VALO**2))                          24780000
CDC   THETA=2.0*57.295779* ASIN(EXP(-VAUP**2))                          24790000
  30  TLBDG=2.0*57.295779* ASIN(EXP(-VALO**2))                          24800000
      THETA=2.0*57.295779* ASIN(EXP(-VAUP**2))                          24810000
      WRITE(66,32)TLBDG,THETA                                           24820000
  32  FORMAT(56H TOTAL LABORATORY CROSS SECTIONS IN RING COUNTER BETWEEN24830001
     1 ,F7.2,13H DEGREES AND ,F7.2, 8H DEGREES )                        24840001
  31  WRITE(66,6)                                                       24850000
   6  FORMAT(1X/6X,1HN,18X,9HSIGTOT(N) )                                24860001
      NMIN=2                                                            24870000
      IF(TLBDG.NE.0.0.AND.VAUP.LT.3.0) NMIN=1                           24880000
      DO 4 N=NMIN,NMAXIN                                                24890000
      ACCSIG(N)=3.0*ACCIN*SQRT(PIN(N))*DISTA**2                         24900000
      IJST=IFIX(ALOG(SIGTOT(N)/ACCSIG(N))/2.302 +2.5)                   24910000
      IF(IJST.LT.0) IJST=0                                              24920000
      IF(IJST.GT.9) IJST=9                                              24930000
C     WRITE(7,75) N,SIGTOT(N),EP                                        24940000
   4  WRITE(66,75) N,SIGTOT(N)                                          24950000
  75  FORMAT(5X,I3,11X,E19.4)                                           24960000
      NMAX=1                                                            24970000
      IF(OUANG3) 600,690,600                                            24980000
 600  WRITE(66,601)                                                     24990000
 601  FORMAT(53H1TOTAL ANGULAR DISTRIBUTION TENSORS ANG3T(N,KA,KAPPA)//)25000000
      CALL TENTOT(6)                                                    25010000
 690  IF(OUANG5) 610,466,610                                            25020000
 610  WRITE(66,611)                                                     25030000
 611  FORMAT(54H1TOTAL ANGULAR DISTRIBUTION TENSORS ANG3RT(N,KA,KAPPA)  25040000
     1//)                                                               25050000
      WRITE(66,543) TGAMMA,PGAMMA                                       25060000
      CALL TENTOT(12)                                                   25070000
 466  CONTINUE                                                          25080000
      RETURN                                                            25090000
      END                                                               25100000
      SUBROUTINE START                                                  25110000
C                                                                       25120000
C     THIS ROUTINE STARTS EXECUTION OF PROGRAM                          25130000
C                                                                       25140000
      LOGICAL ERR                                                       25150000
      INTEGER SSTART,SSTOP                                              25160000
      COMPLEX ANG3RT                                                    25170000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  25180000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       25190000
     1SSTART(31),SSTOP(30)                                              25200000
      COMMON/EMR/QZERO,ALPHA0,ALPHA2,QUINT2,QUINT4,QUINT6               25210000
      COMMON/EROR/ERR                                                   25220000
      INTEGER OUAMP,OUPROW                                              25230000
      INTEGER OUXI,OUPSI                                                25240000
      INTEGER OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5                 25250000
      REAL ME                                                           25260000
      COMMON/AR/NANGLE,THI,TLI                                          25270000
      COMMON/RPST/THETA                                                 25280000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   25290000
      COMMON/ARS/SIMP                                                   25300000
      COMMON/RI/OUAMP,OUPROW,INTERV,INTIN                               25310000
      COMMON/RP/OUXI,OUPSI,NCM,EMMAX1                                   25320000
      COMMON/ARI/NTIME                                                  25330000
      COMMON/RPIS/XIMAX                                                 25340000
      COMMON/RP1M/ME(30,30,12)                                          25350000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          25360000
      COMMON/ALL/NMAX,NDIM,NCORR                                        25370000
      COMMON/RS/NMAXIN,SIGTOT(30),ACCIN,PIN(30),VA,DVA,VALO,VAUP        25380000
      COMMON/ART/OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5              25390000
      COMMON/TTOT/ANG3T(30,3,5),ANG3RT(30,3,5)                          25400000
      COMMON/SR/DTHETA,DTLBDG                                           25410000
      COMMON/STT/DTHETR,DTLBR                                           25420000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       25430000
      COMMON/RDSTA/IPAR(30),IFAC(30)                                    25440000
      COMMON/HJW/IPRINT
C                                                                       25450000
      CALL MAT                                                          25460000
      IF (NGMAX.NE.1) GOTO 50                                           25470000
C     PROGRAM BUILDS GROUPS IF  NGMAX .GT. 11                           25480000
      NGMAX = NMAX/11                                                   25490000
      NGMAX = NGMAX + 1                                                 25500000
      IF(MOD(NMAX,11).EQ.0) NGMAX=NMAX/11                               25510000
      NSTA = 1                                                          25520000
      NSTO = 11                                                         25530000
      DO 100 I=1,NGMAX                                                  25540000
      IEXCIT(I) = IEXCIT(1)                                             25550000
      EMMAX(I) = EMMAX1                                                 25560000
      NSTART(I) = NSTA                                                  25570000
      NSTOP(I) = NSTO                                                   25580000
      IF(I.EQ.NGMAX) NSTOP(I)=NMAX                                      25590000
      NSTA = NSTA+11                                                    25600000
      NSTO = NSTO+11                                                    25610000
 100  CONTINUE                                                          25620000
C     COMPUTATION OF MISTER - MATRIX                                    25630000
  50  DO 110 I=1,NGMAX                                                  25640000
      DO 115 J=1,NGMAX                                                  25650000
      IF(MISTER(I,J).EQ.0)GOTO 115                                      25660000
      MISTER(I,J) = 0                                                   25670000
      N1 = NSTART(I)                                                    25680000
      N2 = NSTOP(I)                                                     25690000
      M1 = NSTART(J)                                                    25700000
      M2 = NSTOP(J)                                                     25710000
      DO 120 L=1,LAMMAX                                                 25720000
      LAM = LAMDA(L)                                                    25730000
      DO 125 N=N1,N2                                                    25740000
      DO 130 M=M1,M2                                                    25750000
      IF(ME(N,M,LAM).NE.0.) MISTER(I,J)=1                               25760000
 130  CONTINUE                                                          25770000
 125  CONTINUE                                                          25780000
 120  CONTINUE                                                          25790000
 115  CONTINUE                                                          25800000
 110  CONTINUE                                                          25810000
C     SYMMETRIZATION OF MISTER - MATRIX                                 25820000
      DO 60 I1 = 1,NGMAX                                                25830000
      DO 61 I2 = I1,NGMAX                                               25840000
      MISTER(I2,I1) = MISTER(I1,I2)                                     25850000
  61  CONTINUE                                                          25860000
  60  CONTINUE                                                          25870000
C     COMPUTATION OF IFAC-ARRAY                                         25880000
 480  DO 580 K=1,IEXNUM                                                 25890000
      NN = 1                                                            25900000
      IF(K.EQ.2) NN = NSTART(IP)                                        25910000
      IF(K.EQ.2)GOTO 582                                                25920000
      N1 = 1                                                            25930000
      N2 = NMAX                                                         25940000
      IF(IEXNUM.EQ.2) N2 = NSTART(IP) - 1                               25950000
      GOTO 581                                                          25960000
 582  N1 = NSTART(IP)                                                   25970000
      N2 = NMAX                                                         25980000
 581  DO 40 N=N1,N2                                                     25990000
      ISPIN = SPIN(N) + 0.0001                                          26000000
      IDPAR = 0                                                         26010000
      IF(IPAR(N).NE.IPAR(NN)) IDPAR=1                                   26020000
      IFAC(N) = (-1)**(IDPAR-ISPIN)                                     26030000
  40  CONTINUE                                                          26040000
 580  CONTINUE                                                          26050000
      INTERV=INTIN                                                      26060000
      ACCUR=ACCIN                                                       26070000
      NMAX=NMAXIN                                                       26080000
      TLBDG = TLI                                                       26090000
      THETA = THI                                                       26100000
      IF (NCM .GT. NMAX) NCM = NMAX                                     26110000
1001  WRITE(66,430)                                                     26120000
 430  FORMAT(54H1DE BOER - WINTHER MULTIPLE COULOMB EXCITATION PROGRAM, 26130000
     12X,26HFOR  E1 - E6  AND  M1 - M6)                                 26140000
      WRITE(66,431) Z1,A1,EP                                            26150000
 431  FORMAT(32H PROJECTILE CHARGE NUMBER  Z1 = ,F6.2,14H,  MASS  A1 = ,26160001
     1F8.3,23HAMU,  LAB ENERGY  EP = ,F8.3,3HMEV)                       26170001
      WRITE(66,555) QPAR                                                26180000
 555  FORMAT(23H  E1-POLARISATION,QPAR=,F7.4)                           26190001
      IF(TLBDG.EQ.0.0.AND.THETA.EQ.0.0) GO TO 103                       26200000
      IF(TLBDG.NE.0.0.AND.THETA.NE.0.0) GO TO 810                       26210000
      SIMP = 0.0                                                        26220000
      NANGLE=0                                                          26230000
      IF(TLBDG)432,433,432                                              26240000
 433  WRITE(66,434) THETA                                               26250000
 434  FORMAT(52H SCATTERING ANGLE IN CENTER OF MASS SYSTEM  THETA = ,   26260001
     1F7.2,8H DEGREES)                                                  26270001
      GO TO 435                                                         26280000
 432  WRITE(66,436) TLBDG                                               26290000
 436  FORMAT(48H SCATTERING ANGLE IN LABORATORY SYSTEM  TLBDG = ,F7.2,  26300001
     1 8H DEGREES)                                                      26310000
 435  WRITE(66,437) Z2,A2                                               26320000
 437  FORMAT(28H TARGET CHARGE NUMBER  Z2 = ,F6.2,14H,  MASS  A2 = ,F8.326330001
     1,3HAMU/)                                                          26340001
      WRITE(66,72) NGMAX                                                26350000
  72  FORMAT(27H NUMBER OF GROUPS   NGMAX =,I3)                         26360001
      WRITE(66,70)                                                      26370000
  70  FORMAT(///16H ENERGY SPECTRUM)                                    26380001
      DO 71 I=1,NGMAX                                                   26390000
      N1 = NSTART(I)                                                    26400000
      N2 = NSTOP(I)                                                     26410000
      WRITE(66,10) I, (N,N=N1,N2)                                       26420000
  10  FORMAT(//3X,5HGROUP,I3,9X,13HLEVEL INDEX N,11I8,/40X,11I8)        26430000
      WRITE(66,20)(EN(N),N=N1,N2)                                       26440000
  20  FORMAT(1X/20X,13HENERGY IN MEV,11F8.4,/(40X,11F8.4))              26450001
      WRITE(66,30)(SPIN(N),N=N1,N2)                                     26460000
  30  FORMAT(1X/20X,4HSPIN,9X,11F8.4,/(40X,11F8.4))                     26470001
      WRITE(66,35) (IPAR(N),N=N1,N2)                                    26480000
  35  FORMAT(1X/20X,6HPARITY,7X,11I8)                                   26490001
  71  CONTINUE                                                          26500000
      IF(NGMAX.EQ.1) GOTO 77                                            26510000
C     PRINTOUT OF MISTER - MATRIX                                       26520000
      WRITE(66,73)                                                      26530000
  73  FORMAT(////16H MISTER - MATRIX)                                   26540001
      WRITE(66,74) ( I, I=1,NGMAX)                                      26550000
  74  FORMAT(7X,10I10)                                                  26560000
      DO 75 N=1,NGMAX                                                   26570000
      WRITE(66,76) N, ( MISTER(N,I), I = 1,NGMAX)                       26580000
  76  FORMAT(4H N =,I3,10I10)                                           26590001
  75  CONTINUE                                                          26600000
  77  CONTINUE                                                          26610000
C THE MATRIX ELEMENTS ARE PRINTED                                       26620000
  88  WRITE(66,43)                                                      26630000
  43  FORMAT(///44H MULTIPOLE MATRIX ELEMENTS IN BARNS**(LAM/2))        26640001
      DO 38 I5=1,LAMMAX                                                 26650000
      LAM = LAMDA(I5)                                                   26660000
      WRITE(66,36) LAM                                                  26670000
  36  FORMAT(/11H MATRIX  ME,I2,5H(N,M))                                26680001
      DO 400 I=1,NGMAX                                                  26690000
      N1 = NSTART(I)                                                    26700000
      N2 = NSTOP(I)                                                     26710000
      DO 410 J=1,NGMAX                                                  26720000
      IF(MISTER(I,J).EQ.0)GOTO 410                                      26730000
      M1 = NSTART(J)                                                    26740000
      M2 = NSTOP(J)                                                     26750000
      WRITE(66,900) I,J                                                 26760000
 900  FORMAT(1X/5X,23HGROUP COMBINATION  I1 =,I2,6H, I2 =,I2)           26770001
      WRITE(66,910) (M,M=M1,M2)                                         26780000
 910  FORMAT(6X,I14,10I11)                                              26790000
      DO 34 N=N1,N2                                                     26800000
      WRITE(66,915) N,(ME(N,M,LAM),M=M1,M2)                             26810000
 915  FORMAT(1H ,5X,3HN =,I2,11F11.4)                                   26820001
  34  CONTINUE                                                          26830000
 410  CONTINUE                                                          26840000
 400  CONTINUE                                                          26850000
  38  CONTINUE                                                          26860000
      WRITE(66,442)                                                     26870000
 442  FORMAT(75H PERFORMANCE CONTROLS  NMAX,   INTERV,   NCM,   XIMAX,  26880001
     1   ACCUR,     NTIME)                                              26890000
C     IF (NGMAX.NE.1) GOTO 601                                          26900000
C     WRITE(66,446)                                                     26910000
C446  FORMAT(1H+,75X,10H,   EMMAX1)                                     26920000
 601  WRITE(66,443)NMAX,INTERV,NCM,XIMAX,ACCUR,NTIME                    26930000
 443  FORMAT(1X/19X,I6,2X,2I8,F9.2,F13.7,I9)                            26940001
C     IF (NGMAX.NE.1) GOTO 602                                          26950000
C     WRITE(66,447) EMMAX1                                              26960000
C447  FORMAT(1H+,76X,F9.2)                                              26970000
C     GOTO 450                                                          26980000
 602  WRITE(66,451) (I,I=1,NGMAX)                                       26990000
 451  FORMAT(12H GROUP NO. I,10(6X,I2,2X))                              27000001
      WRITE(66,452) (EMMAX(I),I=1,NGMAX)                                27010000
 452  FORMAT(9H EMMAX(I),3X,10(5X,F5.1))                                27020000
      WRITE(66,454) (IEXCIT(I),I=1,NGMAX)                               27030000
 454  FORMAT(10H IEXCIT(I),2X,10(6X,I2,2X))                             27040000
 450  WRITE(66,444)                                                     27050000
 444  FORMAT(81H OUTPUT CONTROLS       OUXI, OUPSI, OUAMP, OUPROW, OUANG27060001
     10, OUANG1, OUANG2, OUANG3)                                        27070000
      WRITE(66,445) OUXI,OUPSI,OUAMP,OUPROW,OUANG0,OUANG1,OUANG2,OUANG3 27080000
 445  FORMAT(1X/17X,3I7,5I8)                                            27090001
C **********************************************************************27100000
C **********************************************************************27110000
C **********************************************************************27120000
      IF(IPRINT.GT.0) GOTO 7000                                         27130000
      IPRINT=IPRINT+1                                                   27140000
      WRITE(67,8000) Z1,A1,Z2,A2,EP,QPAR                                27150000
 8000 FORMAT(10F10.4)
      WRITE(67,8001) NMAX                                               27160000
 8001 FORMAT(10I10)
      DO 7001 IWOLLE=1,NMAX                                             27170000
      WRITE(67,8002) SPIN(IWOLLE),EN(IWOLLE),IPAR(IWOLLE)               27180000
 8002 FORMAT(2F10.3,I10)
 7001 CONTINUE                                                          27190000
      WRITE(67,8003) INTERV,NCM,EMMAX1,XIMAX,ACCUR,NTIME                27200000
 8003 FORMAT(2I10,3F10.5,I10)
      WRITE(67,8001) OUXI,OUPSI,OUAMP,OUPROW,OUANG0,OUANG1,OUANG2,OUANG327210000
      DO 7003 IME14=1,4                                                 27220000
      DO 7002 IWOLLE=1,NMAX                                             27230000
      WRITE(67,8000) (ME(IWOLLE,IW,IME14),IW=1,NMAX)                    27240000
 7002 CONTINUE                                                          27250000
 7003 CONTINUE                                                          27260000
 7000 WRITE(67,8000) THETA                                              27270000
C **********************************************************************27280000
C **********************************************************************27290000
C **********************************************************************27300000
      GO TO 31                                                          27310000
 103  CONTINUE                                                          27320000
      VAUP = 77.7                                                       27330000
      WRITE(66,782)                                                     27340000
 782  FORMAT(69H TOTAL CROSS SECTIONS FROM CENTER OF MASS DIFFERENTIAL C27350001
     1ROSS SECTIONS)                                                    27360000
      DVA=1.2*(ACCUR)**0.25                                             27370000
      DTHETA=90.0-57.295779*ASIN(EXP(-DVA**2))                          27380000
CDC   DTHETA=90.0-57.295779*ASIN(EXP(-DVA**2))                          27390000
      NANGLE = 180.0/DTHETA                                             27400000
      IF(MOD(NANGLE,2).EQ.0)GOTO 785                                    27410000
      NANGLE = NANGLE + 1                                               27420000
 785  DTHETA = 180.0/FLOAT(NANGLE)                                      27430000
      DTHETR = DTHETA/57.295779                                         27440000
      THETA = 180.0 - DTHETA                                            27450000
      SIMP = 4.0                                                        27460000
      GO TO 200                                                         27470000
 810  IF(TLBDG.LE.THETA) GO TO 821                                      27480000
      WRITE(66,811)TLBDG,THETA                                          27490000
 811  FORMAT(49H TOTAL LABORATORY CROSS SECTIONS BETWEEN TLBDG = ,F7.2, 27500001
     120H DEGREES AND TLBDG = ,F7.2,8H DEGREES )                        27510001
      DELTHE = TLBDG - THETA                                            27520000
      VALO=SQRT(-ALOG(SIN(TLBDG/(2.0*57.295779))))                      27530000
      VAUP=SQRT(-ALOG(SIN(THETA/(2.0*57.295779))))                      27540000
      DVA=1.2*(ACCUR**0.25)                                             27550000
      DELVA=VAUP-VALO                                                   27560000
      IF(DVA.GT.DELVA**0.75) GO TO 201                                  27570000
      IF(VAUP.GT.2..AND.VALO.LT.2.) DELVA=2.-VALO                       27580000
      N=0.5*DELVA/DVA + 1.0                                             27590000
      NANGLE=2*N                                                        27600000
      DTLBDG = DELTHE/FLOAT(NANGLE)                                     27610000
      DTLBR = DTLBDG/57.295779                                          27620000
      SIMP =1.0                                                         27630000
      GO TO 200                                                         27640000
 201  IF(DVA.GT.    DELVA**0.5) GO TO 202                               27650000
      DTLBDG = 0.6*DELTHE                                               27660000
      DTLBR=DTLBDG/57.295779                                            27670000
      TLBDG = TLBDG-0.2*DELTHE                                          27680000
      NANGLE=2                                                          27690000
      SIMP=2.5                                                          27700000
      GO TO 200                                                         27710000
 202  TLBDG = TLBDG-0.5*DELTHE                                          27720000
      DTLBDG = DELTHE                                                   27730000
      DTLBR=DTLBDG/57.295779                                            27740000
      NANGLE=1                                                          27750000
      SIMP=3.0                                                          27760000
 200  CONTINUE                                                          27770000
      DO 814 N=1,NMAX                                                   27780000
      PIN(N)=0.0                                                        27790000
      SIGTOT(N) = 0.0                                                   27800000
      DO 814 L=1,5                                                      27810000
      DO 814 K=1,3                                                      27820000
      ANG3T(N,K,L) = 0.0                                                27830000
      ANG3RT(N,K,L) = (0.,0.)                                           27840000
 814  CONTINUE                                                          27850000
      GO TO 435                                                         27860000
  31  CONTINUE                                                          27870000
      RETURN                                                            27880000
 821  WRITE(66,820)                                                     27890000
 820  FORMAT(69H ERROR - ILLEGAL DEFINITION OF TLBDG AND THETA - EXECUTI27900001
     1ON TERMINATED)                                                    27910000
      ERR = .TRUE.                                                      27920000
      RETURN                                                            27930000
      END                                                               27940000
      SUBROUTINE TENS                                                   27950000
C                                                                       27960000
C     THIS ROUTINE COMPUTES THE ANGULAR DISTRIBUTION TENSORS            27970000
C                                                                       27980000
      INTEGER SSTART,SSTOP                                              27990000
      COMPLEX AMP,TE,CI,R                                               28000000
      COMPLEX ANG0,ANG1,ANG2,ANG4,ANG3R                                 28010000
      INTEGER OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5                 28020000
      COMMON/EUL/ALPHA,BETA,GAMMA,THETAC,PHIC                           28030000
      COMMON/GAM/TGAMMA,PGAMMA                                          28040000
      COMMON/RP/OUXI,OUPSI,NCM,EMMAX1                                   28050000
      COMMON/RPST/THETA                                                 28060000
      COMMON/P2S/TCMDG(30),ZLBDG(30),R3(30),R4(30),EPP(30),ETP(30)      28070000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   28080000
      COMMON/IITT/AMP(350,4),LLMAX                                      28090000
      COMMON/P1IT/CAT(350,3),ICATMX, ISMAX                              28100000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          28110000
      COMMON/ALL/NMAX,NDIM,NCORR                                        28120000
C     COMMON/ALL/NMAX,NDIM                                              28130000
      COMMON/ART/OUANG0,OUANG1,OUANG2,OUANG3,OUANG4,OUANG5              28140000
      COMMON/IS/P(30)                                                   28150000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       28160000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  28170000
      COMMON/NEWINT/LAMDA(12),LEAD(30,30,12),LDNUM(12,30),LAMMAX,       28180000
     1SSTART(31),SSTOP(30)                                              28190000
      COMMON/TESI1/ANG0(30,3,5),ANG1(30,3,5),ANG2(30,3,5),ANG4( 8,3,5)  28200000
      COMMON/TESI/ANG3(30,3,5),ANG3R(30,3,5)                            28210000
      COMMON/VEL/WDCP,WDCT                                              28220000
      DIMENSION PA(9)                                                   28230000
      DATA CI/(0.0,1.0)/                                                28240000
C                                                                       28250000
C     ANGULAR DISTRIBUTION TENSORS ANG0(N,KA,KAPPA)                     28260000
      DO 100 K=1,IEXNUM                                                 28270000
      N1 = 2                                                            28280000
      N2 = NMAX                                                         28290000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   28300000
      IF(K.EQ.1)GOTO 105                                                28310000
      N1 = NSTART(IP) + 1                                               28320000
      N2 = NMAX                                                         28330000
 105  LLMAX = 2.0*(SPIN(N1-1)+1.0)                                      28340000
      CE3 = 1.0/(2.0*SPIN(N1-1)+1.0)                                    28350000
      DO 110 N=N1,N2                                                    28360000
      CE2 = SQRT(2.0*SPIN(N)+1.0)                                       28370000
      KAMAX = 2.02*SPIN(N)                                              28380000
      IF(KAMAX.GT.4) KAMAX=4                                            28390000
      KASTOP = KAMAX + 1                                                28400000
      KA = 0                                                            28410000
      DO 120 KAI=1,KASTOP,2                                             28420000
C     KAI IS INDEX COUNTER ONLY                                         28430000
      KAPSTP = KA + 1                                                   28440000
C     CALCULATION OF ANG0 FOR KAPPA = K,K-1,......,0                    28450000
      KAPPA = KA                                                        28460000
      DO 130 KAPPI=1,KAPSTP                                             28470000
C     KAPPI IS INDEX COUNTER ONLY                                       28480000
      TE = (0.0,0.0)                                                    28490000
      IR1 = SSTART(N)                                                   28500000
      IR2 = SSTOP(N)                                                    28510000
      DO 140 IR=IR1,IR2                                                 28520000
      IRP = IR - KAPPA                                                  28530000
      IF(IRP.LT.SSTART(N))GOTO 140                                      28540000
C     NOW COMES DEFINITION OF THE ARGUMENTS OF THE THREE-J SYMBOL       28550000
      AA1 = SPIN(N)                                                     28560000
      BB1 = -CAT(IR,3)                                                  28570000
      BB2 = CAT(IRP,3)                                                  28580000
      AA3 = KA                                                          28590000
      BB3 = KAPPA                                                       28600000
      IEX = SPIN(N) + CAT(IR,3) + 0.01                                  28610000
      FAC = (-1)**IEX * THREEJ(AA1,BB1,AA1,BB2,AA3,BB3)                 28620000
C     SUMMATION OVER GROUND STATE POLARIZATIONS                         28630000
      L = 1                                                             28640000
 150  CONTINUE                                                          28650000
      LL = L + L                                                        28660000
      LLL = LLMAX - LL                                                  28670000
      IF (LLL) 158,157,156                                              28680000
C     STATEMENT 156 STARTS SUMMATION FOR NEGATIVE QUANTUM NUMBERS       28690000
 156  TE = TE + FAC * AMP(IR,L) * CONJG(AMP(IRP,L))                     28700000
 157  CONTINUE                                                          28710000
C     STATEMENT 157 COMPLETES SUMMATION FOR MAGNETIC QUANTUM NUMBERS .GE28720000
      JR = 2.02*CAT(IR,3)                                               28730000
      JRP = 2.02*CAT(IRP,3)                                             28740000
      IRPOS = IR - JR                                                   28750000
      IRPPOS = IRP - JRP                                                28760000
      TE = TE + FAC * AMP(IRPOS,L) * CONJG(AMP(IRPPOS,L))               28770000
      L = L + 1                                                         28780000
      GOTO 150                                                          28790000
 158  CONTINUE                                                          28800000
 140  CONTINUE                                                          28810000
      KAINDX = KA/2 + 1                                                 28820000
      KAPPIN = KAPPA + 1                                                28830000
      ANG0(N,KAINDX,KAPPIN) = CE2*CE3*TE                                28840000
C                                                                       28850000
C     ANGULAR DISTRIBUTION TENSORS ANG1(N,KA,KAPPA)                     28860000
 168  ANG1(N,KAINDX,KAPPIN) = CI**KAPPA * ANG0(N,KAINDX,KAPPIN)         28870000
      KAPPA = KAPPA - 1                                                 28880000
 130  CONTINUE                                                          28890000
      KA = KA + 2                                                       28900000
 120  CONTINUE                                                          28910000
C     FOLLOWING INSTRUCTION SKIPS A LINE IN PRINTOUT WHEN N CHANGES     28920000
 110  CONTINUE                                                          28930000
 100  CONTINUE                                                          28940000
C                                                                       28950000
C     THE ANGULAR DISTRIBUTION TENSORS ANG2(N,KA,KAPPA)                 28960000
 200  IF (OUANG2) 205,300,205                                           28970000
 205  DO 210 K=1,IEXNUM                                                 28980000
      N1 = 2                                                            28990000
      N2 = NMAX                                                         29000000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   29010000
      IF(K.EQ.1)GOTO 215                                                29020000
      N1 = NSTART(IP) + 1                                               29030000
      N2 = NMAX                                                         29040000
 215  DO 220 N=N1,N2                                                    29050000
      KA = 0                                                            29060000
      KAMAX = 2.02*SPIN(N)                                              29070000
      IF(KAMAX.GT.4) KAMAX=4                                            29080000
      KASTOP = KAMAX + 1                                                29090000
      DO 230 KAI=1,KASTOP,2                                             29100000
C     KAI IS INDEX COUNTER ONLY                                         29110000
      DJ = KA                                                           29120000
      KAINDX = KA/2 + 1                                                 29130000
      KAPPA = KA                                                        29140000
      KAPSTP = KA + 1                                                   29150000
      DO 240 KAPPI=1,KAPSTP,2                                           29160000
C     KAPPI IS INDEX COUNTER ONLY                                       29170000
      DMP = KAPPA                                                       29180000
      KAPPIN = KAPPA + 1                                                29190000
      TE = (0.0,0.0)                                                    29200000
      IF(KA.LT.4)GOTO 250                                               29210000
      TE = REAL(ANG1(N,KAINDX,5)) * (DJMM(-90.0,DJ,4.0,DMP) +           29220000
     1DJMM(-90.0,DJ,-4.0,DMP))                                          29230000
      TE = TE + CI * REAL(ANG1(N,KAINDX,4)) * ( DJMM(-90.0,DJ,3.0,DMP) +29240000
     1DJMM(-90.0,DJ,-3.0,DMP))                                          29250000
 250  IF(KA.LT.2)GOTO 260                                               29260000
      TE = TE - REAL(ANG1(N,KAINDX,3)) * ( DJMM(-90.0,DJ,2.0,DMP) +     29270000
     1DJMM(-90.0,DJ,-2.0,DMP))                                          29280000
      TE = TE - CI * REAL(ANG1(N,KAINDX,2)) * ( DJMM(-90.0,DJ,1.0,DMP)  29290000
     1+ DJMM(-90.0,DJ,-1.0,DMP))                                        29300000
 260  TE = TE + REAL(ANG1(N,KAINDX,1)) * DJMM(-90.0,DJ,0.0,DMP)         29310000
      ANG2(N,KAINDX,KAPPIN) = TE                                        29320000
      KAPPA = KAPPA - 2                                                 29330000
 240  CONTINUE                                                          29340000
      KA = KA + 2                                                       29350000
 230  CONTINUE                                                          29360000
C     FOLLOWING INSTRUCTION SKIPS A LINE IN PRINTOUT WHEN NI CHANGES    29370000
 220  CONTINUE                                                          29380000
 210  CONTINUE                                                          29390000
C                                                                       29400000
C     ANGULAR DISTRIBUTION TENSORS ANG3(N,KA,KAPPA)                     29410000
 300  IF (OUANG3) 305,400,305                                           29420000
 305  DFARG = (180.0 + THETA)/2.0                                       29430000
      DO 310 K=1,IEXNUM                                                 29440000
      N1 = 2                                                            29450000
      N2 = NMAX                                                         29460000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   29470000
      IEXC=IEXCIT(1)                                                    29480000
      IF(K.EQ.1)GOTO 600                                                29490000
      N1 = NSTART(IP) + 1                                               29500000
      N2 = NMAX                                                         29510000
      IEXC=IEXCIT(IP)                                                   29520000
      IF(OUANG5) 600,650,600                                            29530000
 600  IF(TLBDG.EQ.0.)GOTO 620                                           29540000
      IF(IEXC.EQ.2)GOTO 602                                             29550000
      THETAN=TLBDG                                                      29560000
      ENERGY=EPP(NCM)                                                   29570000
      A=A1                                                              29580000
      WDCP = 0.0463365*SQRT(ENERGY/A)                                   29590000
      WDC = WDCP                                                        29600000
      GOTO 650                                                          29610000
 602  THETAN=ZLBDG(NCM)                                                 29620000
      ENERGY=ETP(NCM)                                                   29630000
      A=A2                                                              29640000
      WDCT = 0.0463365*SQRT(ENERGY/A)                                   29650000
      WDC = WDCT                                                        29660000
      GOTO 650                                                          29670000
 620  TCMRAD=THETA/57.2957795                                           29680000
      ZCMDG=180.-THETA                                                  29690000
      ZCMRAD=ZCMDG/57.2957795                                           29700000
      EPMIN=EP-EN(NCM)*(1.+A1/A2)                                       29710000
      TAUP=SQRT(EP/EPMIN)                                               29720000
      TAU=TAUP*A1/A2                                                    29730000
      IF(IEXC.EQ.2)GOTO 630                                             29740000
      DEN=COS(TCMRAD)+TAU                                               29750000
      IF(DEN.LT.1.E-12)GOTO 626                                         29760000
      THETAN=57.2957795*ATAN(SIN(TCMRAD)/DEN)                           29770000
      IF(THETAN.LT.0.) THETAN=180.+THETAN                               29780000
      GOTO 627                                                          29790000
 626  THETAN=90.                                                        29800000
 627  A=A1                                                              29810000
      ENERGY=(A2/(A1+A2))**2*(1.+TAU*TAU+2.*TAU*COS(TCMRAD))*EPMIN      29820000
      WDCP = 0.0463365*SQRT(ENERGY/A)                                   29830000
      WDC = WDCP                                                        29840000
      GOTO 650                                                          29850000
 630  DEN=COS(ZCMRAD)+TAUP                                              29860000
      IF(DEN.LT.1.E-12)GOTO 636                                         29870000
      THETAN=57.2957795*ATAN(SIN(ZCMRAD)/DEN)                           29880000
      GOTO 637                                                          29890000
 636  THETAN=90.                                                        29900000
 637  A=A2                                                              29910000
      ENERGY=A1*A2/(A1+A2)**2*(1.+TAUP*TAUP+2.*TAUP*COS(ZCMRAD))*EPMIN  29920000
      WDCT = 0.0463365*SQRT(ENERGY/A)                                   29930000
      WDC = WDCT                                                        29940000
 650  DO 320 N=N1,N2                                                    29950000
      KA = 0                                                            29960000
      KAMAX = 2.02*SPIN(N)                                              29970000
      IF(KAMAX.GT.4) KAMAX=4                                            29980000
      KASTOP = KAMAX + 1                                                29990000
      DO 330 KAI=1,KASTOP,2                                             30000000
C     KAI IS INDEX COUNTER ONLY                                         30010000
      DJ = KA                                                           30020000
      KAINDX = KA/2 + 1                                                 30030000
      KAPPA = KA                                                        30040000
      KAPSTP = KA + 1                                                   30050000
      DO 340 KAPPI=1,KAPSTP                                             30060000
C     KAPPI IS INDEX COUNTER ONLY                                       30070000
      DMP = KAPPA                                                       30080000
      KAPPIN = KAPPA + 1                                                30090000
      SUM = 0.0                                                         30100000
C     SUMMATION OVER INDICES .GE. 0  IN EQUATION (50)                   30110000
      KPR = 0                                                           30120000
  85  DM = KPR                                                          30130000
      KPRI = KPR + 1                                                    30140000
      SUM = SUM + REAL(ANG1(N,KAINDX,KPRI))*DJMM(DFARG,DJ,DM,DMP)       30150000
      KPR = KPR + 1                                                     30160000
      IF (KPR-KA) 85,85,86                                              30170000
  86  CONTINUE                                                          30180000
      IF(KA.EQ.0)GOTO 309                                               30190000
C     SUMMATION OVER NEGATIVE INDICES IN EQUATION (50)                  30200000
      KPR = 1                                                           30210000
 308  DM = -KPR                                                         30220000
      KPRI = KPR + 1                                                    30230000
      SUM=SUM+(-1)**KPR*REAL(ANG1(N,KAINDX,KPRI))*DJMM(DFARG,DJ,DM,DMP) 30240000
      KPR = KPR + 1                                                     30250000
      IF (KPR - KA) 308,308,309                                         30260000
 309  ANG3(N,KAINDX,KAPPIN) = (-1)**KAPPA * SUM                         30270000
      IF(OUANG5) 311,312,311                                            30280000
 311  ANG3R(N,KAINDX,KAPPIN) = ANG3(N,KAINDX,KAPPIN) *                  30290000
     1(1.+WDC*R(KA,KAPPA,THETAN,TGAMMA,PGAMMA))                         30300000
 312  KAPPA = KAPPA - 1                                                 30310000
 340  CONTINUE                                                          30320000
      KA = KA + 2                                                       30330000
 330  CONTINUE                                                          30340000
C     FOLLOWING INSTRUCTION SKIPS A LINE IN PRINTOUT WHEN N CHANGES     30350000
 320  CONTINUE                                                          30360000
 310  CONTINUE                                                          30370000
 400  CONTINUE                                                          30380000
C                                                                       30390000
C     ANGULAR DISTRIBUTION TENSORS ANG4(N,KA,KAPPA)                     30400000
      IF(OUANG4) 405,500,405                                            30410000
 405  CALL EULER                                                        30420000
      ALPHAR = ALPHA/57.295779                                          30430000
      BETAR = BETA/57.295779                                            30440000
      GAMMAR = GAMMA/57.295779                                          30450000
      DO 410 K=1,IEXNUM                                                 30460000
      N1 = 2                                                            30470000
      N2 = NMAX                                                         30480000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   30490000
      IF(K.EQ.1)GOTO 415                                                30500000
      N1 = NSTART(IP) + 1                                               30510000
      N2 = NMAX                                                         30520000
 415  DO 420 N=N1,N2                                                    30530000
      KA = 0                                                            30540000
      KAMAX = 2.02*SPIN(N)                                              30550000
      IF(KAMAX.GT.4) KAMAX=4                                            30560000
      KASTOP = KAMAX + 1                                                30570000
      DO 430 KAI=1,KASTOP,2                                             30580000
C     KAI IS INDEX COUNTER ONLY                                         30590000
      DJ = KA                                                           30600000
      KAINDX = KA/2 + 1                                                 30610000
      KAPPA = KA                                                        30620000
      KAPSTP = KA + 1                                                   30630000
      DO 440 KAPPI=1,KAPSTP                                             30640000
C     KAPPI IS INDEX COUNTER ONLY                                       30650000
      DMP = KAPPA                                                       30660000
      KAPPIN = KAPPA + 1                                                30670000
      TE = (0.,0.)                                                      30680000
C     SUMMATION OVER INDICES .GE. 0 IN EQUATION (50)                    30690000
      KPR = 0                                                           30700000
  45  DM = KPR                                                          30710000
      KPRI = KPR + 1                                                    30720000
      TE = TE+CI**(-KPR)*REAL(ANG1(N,KAINDX,KPRI))*(COS(KPR*ALPHAR)+    30730000
     1CI*SIN(KPR*ALPHAR))*DJMM(BETA,DJ,DM,DMP)                          30740000
      KPR = KPR + 1                                                     30750000
      IF(KPR-KA) 45,45,46                                               30760000
  46  CONTINUE                                                          30770000
      IF(KA.EQ.0)GOTO 409                                               30780000
C     SUMMATION OVER NEGATIVE INDICES IN EQUATION (50)                  30790000
      KPR = 1                                                           30800000
 408  DM = -KPR                                                         30810000
      KPRI = KPR + 1                                                    30820000
      TE = TE+CI**KPR*(-1)**KPR*REAL(ANG1(N,KAINDX,KPRI))*(COS(-KPR*    30830000
     1ALPHAR)+CI*SIN(-KPR*ALPHAR))*DJMM(BETA,DJ,DM,DMP)                 30840000
      KPR = KPR + 1                                                     30850000
      IF(KPR-KA) 408,408,409                                            30860000
 409  ANG4(N,KAINDX,KAPPIN)=TE*(COS(KAPPA*GAMMAR)+CI*SIN(KAPPA*GAMMAR)) 30870000
      KAPPA = KAPPA - 1                                                 30880000
 440  CONTINUE                                                          30890000
      KA = KA + 2                                                       30900000
 430  CONTINUE                                                          30910000
 420  CONTINUE                                                          30920000
 410  CONTINUE                                                          30930000
 500  RETURN                                                            30940000
      END                                                               30950000
      SUBROUTINE TENTOT(I)                                              30960000
C                                                                       30970000
C     THIS ROUTINE PRINTS OUT THE ANGULAR DISTRIBUTION TENSORS          30980000
C     IT COMPUTES TOTAL ANGULAR DISTRIBUTION TENSORS                    30990000
C                                                                       31000000
      COMPLEX ANG0,ANG1,ANG2,ANG4,ANG3R,ANG3RT                          31010000
      COMMON/TESI1/ANG0(30,3,5),ANG1(30,3,5),ANG2(30,3,5),ANG4( 8,3,5)  31020000
      COMMON/ARS/SIMP                                                   31030000
      COMMON/RPS/Z1,Z2,A1,A2,EP,TLBDG                                   31040000
      COMMON/TTOT/ANG3T(30,3,5),ANG3RT(30,3,5)                          31050000
      COMMON/TESI/ANG3(30,3,5),ANG3R(30,3,5)                            31060000
      COMMON/SIG/DSIG(30),DSIGLB(30),ACCSIG(30),RU(30)                  31070000
      COMMON/P2S/TCMDG(30),ZLBDG(30),R3(30),R4(30),EPP(30),ETP(30)      31080000
      COMMON/RS/NMAXIN,SIGTOT(30),ACCIN,PIN(30),VA,DVA,VALO,VAUP        31090000
      COMMON/GROUPS/NGMAX,NSTART(10),NSTOP(10),MISTER(10,10),EMMAX(10)  31100000
      COMMON/EXCIT/IEXCIT(10),IEXNUM,LMAX(2),IRSTA(2),IRSTO(2),IP       31110000
      COMMON/RPMTIS/EN(30),SPIN(30),ACCUR,QPAR                          31120000
      COMMON/STT/DTHETR,DTLBR                                           31130000
      COMMON/RPST/THETA                                                 31140000
      COMMON/VEL/WDCP,WDCT                                              31150000
      COMMON WANG3(30,5,5)                                              31160000
C                                                                       31170000
      DO 540 K=1,IEXNUM                                                 31180000
      N1 = 2                                                            31190000
      N2 = NMAXIN                                                       31200000
      IF(IEXNUM.EQ.2) N2=NSTART(IP)-1                                   31210000
      IEXC = IEXCIT(1)                                                  31220000
      IF(K.EQ.1)GOTO 80                                                 31230000
      N1 = NSTART(IP) + 1                                               31240000
      N2 = NMAXIN                                                       31250000
      IEXC = IEXCIT(IP)                                                 31260000
  80  IF(I.EQ.5.OR.I.EQ.8.OR.I.EQ.10.OR.I.EQ.11)GOTO 150                31270000
      IF(IEXC.EQ.1)GOTO 85                                              31280000
      WRITE(66,900)                                                     31290000
      IF(I.EQ.9) WRITE(66,924)WDCT                                      31300000
      GOTO 90                                                           31310000
  85  WRITE(66,902)                                                     31320000
      IF(I.EQ.9) WRITE(66,924)WDCP                                      31330000
  90  GOTO (100,101,102,103,150,104,105,150,106,150,150,107),I          31340000
 100  WRITE(66,904)                                                     31350000
      GOTO 150                                                          31360000
 101  WRITE(66,906)                                                     31370000
      GOTO 150                                                          31380000
 102  WRITE(66,908)                                                     31390000
      GOTO 150                                                          31400000
 103  WRITE(66,910)                                                     31410000
      GOTO 150                                                          31420000
 104  WRITE(66,912)                                                     31430000
      GOTO 150                                                          31440000
 105  WRITE(66,914)                                                     31450000
      GOTO 150                                                          31460000
 106  WRITE(66,918)                                                     31470000
      GOTO 150                                                          31480000
 107  WRITE(66,922)                                                     31490000
 150  CONTINUE                                                          31500000
      DO 530 N=N1,N2                                                    31510000
      KA = 0                                                            31520000
      KAMAX = 2.02*SPIN(N)                                              31530000
      IF(KAMAX.GT.4) KAMAX=4                                            31540000
      KASTOP = KAMAX + 1                                                31550000
      DO 520 KAI=1,KASTOP,2                                             31560000
C     KAI IS INDEX COUNTER ONLY                                         31570000
      KAINDX = KA/2 + 1                                                 31580000
      KAPSTP = KA + 1                                                   31590000
      KAPPA = KA                                                        31600000
      DO 510 KAPPI=1,KAPSTP                                             31610000
C     KAPPI IS INDEX COUNTER ONLY                                       31620000
      KAPPIN = KAPPA + 1                                                31630000
      GOTO (200,201,202,203,204,205,206,207,208,209,210,211),I          31640000
 200  WRITE(66,920) N,KA,KAPPA,ANG0(N,KAINDX,KAPPIN)                    31650000
      GOTO 500                                                          31660000
 201  RANG1 = REAL(ANG1(N,KAINDX,KAPPIN))                               31670000
      WRITE(66,926) N,KA,KAPPA,RANG1                                    31680000
      GOTO 500                                                          31690000
 202  IF(KAPPA.EQ.1.OR.KAPPA.EQ.3)GOTO 500                              31700000
      WRITE(66,920) N,KA,KAPPA,ANG2(N,KAINDX,KAPPIN)                    31710000
      GOTO 500                                                          31720000
 203  WRITE(66,920) N,KA,KAPPA,ANG3(N,KAINDX,KAPPIN)                    31730000
      GOTO 500                                                          31740000
 204  ANG3T(N,KAINDX,KAPPIN) = ANG3T(N,KAINDX,KAPPIN) + DTHETR/3.0*     31750000
     1SIMP*ANG3(N,KAINDX,KAPPIN)*RU(N)*SIN(THETA/57.295779)*2.*3.141592631760000
      GOTO 500                                                          31770000
 205  WRITE(66,920) N,KA,KAPPA,ANG3T(N,KAINDX,KAPPIN)                   31780000
      GOTO 500                                                          31790000
 206  WRITE(66,920) N,KA,KAPPA,ANG4(N,KAINDX,KAPPIN)                    31800000
      GOTO 500                                                          31810000
 207  ANG3T(N,KAINDX,KAPPIN)=ANG3T(N,KAINDX,KAPPIN)+DTLBR/3.*SIMP*ANG3  31820000
     1(N,KAINDX,KAPPIN)*RU(N)*R3(N)*SIN(TLBDG/57.295779)*2.*3.1415926   31830000
      GOTO 500                                                          31840000
 208  WRITE(66,920) N,KA,KAPPA,ANG3R(N,KAINDX,KAPPIN)                   31850000
      GOTO 500                                                          31860000
 209  ANG3RT(N,KAINDX,KAPPIN)=ANG3RT(N,KAINDX,KAPPIN)+DTHETR/3.0*SIMP   31870000
     1*ANG3R(N,KAINDX,KAPPIN)*RU(N)*SIN(THETA/57.295779)*2.*3.1415926   31880000
      GOTO 500                                                          31890000
 210  ANG3RT(N,KAINDX,KAPPIN)=ANG3RT(N,KAINDX,KAPPIN)+DTLBR/3.*SIMP*ANG331900000
     1R(N,KAINDX,KAPPIN)*RU(N)*R3(N)*SIN(TLBDG/57.295779)*2.*3.1415926  31910000
      GOTO 500                                                          31920000
 211  WRITE(66,920) N,KA,KAPPA,ANG3RT(N,KAINDX,KAPPIN)                  31930000
 500  KAPPA = KAPPA - 1                                                 31940000
 510  CONTINUE                                                          31950000
      KA = KA + 2                                                       31960000
 520  CONTINUE                                                          31970000
      IF(I.NE.5.AND.I.NE.8.AND.I.NE.10.AND.I.NE.11)WRITE(66,916)        31980000
C **************************************************************        31990000
C **************************************************************        32000000
C **************************************************************        32010000
      IF(I.NE.4) GOTO 530                                               32020000
      J113=1                                                            32030000
      DO 7001 J111=1,3                                                  32040000
      DO 7002 J112=1,J113                                               32050000
7002  WANG3(N,J113,J112)=ANG3(N,J111,J112)                              32060000
7001  J113=J113+2                                                       32070000
      WRITE(66,7000) ((WANG3(N,J111,J112),J112=1,J111),J111=1,5,2)      32080000
 7000 FORMAT(1X,9E12.4)                                                 32090000
      WRITE(67,7000) ((WANG3(N,J111,J112),J112=1,J111),J111=1,5,2)      32100000
C **************************************************************        32110000
C **************************************************************        32120000
C **************************************************************        32130000
 530  CONTINUE                                                          32140000
 540  CONTINUE                                                          32150000
      RETURN                                                            32160000
 900  FORMAT(27H TENSORS FOR TARGET NUCLEUS)                            32170001
 902  FORMAT(31H TENSORS FOR PROJECTILE NUCLEUS)                        32180001
 904  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,9HREAL ANG0,11X,9HIMAG ANG0)  32190001
 906  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,9HREAL ANG1)                  32200001
 908  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,9HREAL ANG2,11X,9HIMAG ANG2)  32210001
 910  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,9HREAL ANG3)                  32220001
 912  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,10HREAL ANG3T/)               32230001
 914  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,9HREAL ANG4,11X,9HIMAG ANG4)  32240001
 916  FORMAT(1X/)                                                       32250001
 918  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,10HREAL ANG3R,11X,            32260001
     110HIMAG ANG3R)                                                    32270001
 920  FORMAT(1H ,3I7,2E22.4)                                            32280001
 922  FORMAT(7X,1HN,5X,2HKA,4X,5HKAPPA,9X,11HREAL ANG3RT,               32290001
     111X,11HIMAG ANG3RT)                                               32300001
 924  FORMAT(38H VELOCITY OF DECAYING NUCLEUS   V/C = ,F6.4)            32310001
 926  FORMAT(1H ,3I7,E22.4)                                             32320000
      END                                                               32330000
      FUNCTION THREEJ(A1,B1,A2,B2,A3,B3)                                32340000
C                                                                       32350000
C     THIS ROUTINE COMPUTES THE THREE-J-SYMBOL                          32360000
C                                                                       32370000
      COMMON/FCT10/FCT(100)                                             32380000
      INTEGER Z,ZMIN,ZMAX                                               32390000
      J1=2.001*A1                                                       32400000
      J2=2.001*A2                                                       32410000
      J =2.001*A3                                                       32420000
      M1=2.001*B1                                                       32430000
      M2=2.001*B2                                                       32440000
      M =2.001*B3                                                       32450000
      CC=0.0                                                            32460000
      IF((M1+M2+M.NE.0).OR.(J.GT.J1+J2).OR.(J.LT.IABS(J1-J2))) GO TO 1  32470000
      ZMIN=0                                                            32480000
      IF(J-J2+M1.LT.0) ZMIN=-J+J2-M1                                    32490000
      IF(J-J1-M2+ZMIN.LT.0) ZMIN=-J+J1+M2                               32500000
      ZMAX=J1+J2-J                                                      32510000
      IF(J2+M2-ZMAX.LT.0) ZMAX=J2+M2                                    32520000
      IF(J1-M1-ZMAX.LT.0) ZMAX=J1-M1                                    32530000
      JA=(J1+M1)/2+1                                                    32540000
      JB=JA-M1                                                          32550000
      JC=(J2+M2)/2+1                                                    32560000
      JD=JC-M2                                                          32570000
      JE=(J +M )/2+1                                                    32580000
      JF=JE-M                                                           32590000
      JG=(J1+J2-J)/2+1                                                  32600000
      JH=JA+JB-JG                                                       32610000
      JI=JC+JD-JG                                                       32620000
      JJ=JE+JF+JG-1                                                     32630000
      IF (JJ .GT. 100) GOTO 5                                           32640000
      IA=ZMIN/2                                                         32650000
      IB=JG-IA+1                                                        32660000
      IC=JB-IA+1                                                        32670000
      ID=JC-IA+1                                                        32680000
      IE=JA-JG+IA                                                       32690000
      IF=JD-JG+IA                                                       32700000
      FASE=1.0                                                          32710000
      IF(MOD(IA,2).EQ.0) FASE=-FASE                                     32720000
      Z =ZMIN                                                           32730000
   2  IA=IA+1                                                           32740000
      IB=IB-1                                                           32750000
      IC=IC-1                                                           32760000
      ID=ID-1                                                           32770000
      IE=IE+1                                                           32780000
      IF=IF+1                                                           32790000
      FASE=-FASE                                                        32800000
      STOR=FCT(IA)*FCT(IB)*FCT(IC)*FCT(ID)*FCT(IE)*FCT(IF)              32810000
      IF (STOR.GT.1.0E-40) GO TO 100                                    32820000
      IF (STOR.LT.-1.0E-40) GO TO 100                                   32830000
      THREEJ=0.0                                                        32840000
      GO TO 101                                                         32850000
 100  CONTINUE                                                          32860000
      CC=CC+FASE/STOR                                                   32870000
      Z=Z+2                                                             32880000
      IF(Z.LE.ZMAX) GO TO 2                                             32890000
      FASE=-SIGN(1.0,CC)                                                32900000
      IF(MOD(J1-J2-M,4).EQ.0) FASE=-FASE                                32910000
      STOR=FCT(JJ)                                                      32920000
      IF (STOR.GT.1.0E-40) GO TO 200                                    32930000
      IF (STOR.LT.-1.0E-40) GO TO 200                                   32940000
      THREEJ=0.0                                                        32950000
      GO TO 101                                                         32960000
 200  CONTINUE                                                          32970000
      CC=FASE*SQRT(CC*FCT(JA)*FCT(JB)*FCT(JC)*FCT(JD)*FCT(JE)*CC*       32980000
     1FCT(JF)*FCT(JG)*FCT(JH)*FCT(JI)/STOR)                             32990000
   1  THREEJ=CC/3.16227765                                              33000000
      RETURN                                                            33010000
 101  WRITE(66,102)                                                     33020000
 102  FORMAT(27H DIVISION BY ZERO IN THREEJ)                            33030001
      WRITE(66,8)A1,A2,A3,B1,B2,B3                                      33040000
      RETURN                                                            33050000
   5  WRITE(66,6)                                                       33060000
   6  FORMAT(29H  ERROR - FACTORIALS EXCEEDED)                          33070001
   7  WRITE(66,8)A1,A2,A3,B1,B2,B3                                      33080000
   8  FORMAT(6H RJ1 =,F6.2,6H RJ2 =,F6.2,6H  RJ =,F6.2,6H RM1 =,F6.2,   33090001
     16H RM2 =,F6.2,6H  RM =,F6.2)                                      33100001
      STOP                                                              33110000
      END                                                               33120000
      COMPLEX FUNCTION Y(L,M,THETA,PHI)                                 33130000
C                                                                       33140000
C     THIS ROUTINE COMPUTES SPHERICAL HARMONICS FOR L = 0, 1, 2, 3, 4, 533150000
C                                                                       33160000
      COMPLEX CI,CEPHI                                                  33170000
      DATA CI/(0.,1.)/                                                  33180000
      IF(L.LT.0.OR.L.GT.5)GOTO 890                                      33190000
C     STATEMENT 890 PRINTS OUT ERROR MESSAGE AND STOPS PROGRAM          33200000
      IF(L.LE.0)GOTO 100                                                33210000
      TR = THETA/57.2957795                                             33220000
      PR = PHI/57.2957795                                               33230000
      SINT = SIN(TR)                                                    33240000
      COST = COS(TR)                                                    33250000
      SINP = SIN(PR)                                                    33260000
      COSP = COS(PR)                                                    33270000
      CEPHI = COSP + CI*SINP                                            33280000
      IF(L.LE.1)GOTO 100                                                33290000
      SINT2 = SINT*SINT                                                 33300000
      COST2 = COST*COST                                                 33310000
      IF(L.LE.2)GOTO 100                                                33320000
      SINT3 = SINT2*SINT                                                33330000
      COST3 = COST2*COST                                                33340000
      IF(L.LE.3)GOTO 100                                                33350000
      SINT4 = SINT3*SINT                                                33360000
      COST4 = COST3*COST                                                33370000
      IF(L.LE.4)GOTO 100                                                33380000
      SINT5 = SINT4*SINT                                                33390000
      COST5 = COST4*COST                                                33400000
 100  I = L + 1                                                         33410000
      K = IABS(M) + 1                                                   33420000
      GOTO (200,250,300,350,400,450),I                                  33430000
C     COMPUTES Y FOR L=0                                                33440000
 200  Y = 0.2820948                                                     33450000
      RETURN                                                            33460000
C     COMPUTES Y FOR L=1 AND  M .GE. 0                                  33470000
 250  IF(K.EQ.2)GOTO 261                                                33480000
 260  Y=0.4886025*COST                                                  33490000
      RETURN                                                            33500000
 261  Y=-0.3454941*SINT*CEPHI                                           33510000
      GOTO 850                                                          33520000
C     COMPUTES Y FOR L=2 AND  M .GE. 0                                  33530000
 300  IF(K.EQ.2)GOTO 311                                                33540000
      IF(K.EQ.3)GOTO 312                                                33550000
 310  Y=0.3153916*(3.*COST2-1.)                                         33560000
      RETURN                                                            33570000
 311  Y=-0.7725484*SINT*COST*CEPHI                                      33580000
      GOTO 850                                                          33590000
 312  Y=0.3862742*SINT2*CEPHI*CEPHI                                     33600000
      GOTO 850                                                          33610000
C     COMPUTES Y FOR L=3 AND  M .GE. 0                                  33620000
 350  GOTO(360,361,362,363),K                                           33630000
 360  Y=0.3731763*(5.*COST3-3.*COST)                                    33640000
      RETURN                                                            33650000
 361  Y=-0.3231802*SINT*(5.*COST2-1.)*CEPHI                             33660000
      GOTO 850                                                          33670000
 362  Y=1.0219855*SINT2*COST*CEPHI*CEPHI                                33680000
      GOTO 850                                                          33690000
 363  Y=-0.4172238*SINT3*CEPHI**3                                       33700000
      GOTO 850                                                          33710000
C     COMPUTES Y FOR L=4 AND  M .GE. 0                                  33720000
 400  GOTO(410,411,412,413,414),K                                       33730000
 410  Y=0.1057855*(35.*COST4-30.*COST2+3.)                              33740000
      RETURN                                                            33750000
 411  Y=-0.4730873*SINT*(7.*COST3-3.*COST)*CEPHI                        33760000
      GOTO 850                                                          33770000
 412  Y=0.3345233*SINT2*(7.*COST2-1.)*CEPHI*CEPHI                       33780000
      GOTO 850                                                          33790000
 413  Y=-1.2516715*SINT3*COST*CEPHI**3                                  33800000
      GOTO 850                                                          33810000
 414  Y=0.4425327*SINT4*CEPHI**4                                        33820000
      GOTO 850                                                          33830000
C     COMPUTES Y FOR L=5 AND  M .GE. 0                                  33840000
 450  GOTO(460,461,462,463,464,465),K                                   33850000
 460  Y=0.1169503*(63.*COST5-70.*COST3+15.*COST)                        33860000
      RETURN                                                            33870000
 461  Y=-0.0213521*SINT*(315.*COST4-210.*COST2+15.)*CEPHI               33880000
      GOTO 850                                                          33890000
 462  Y=1.6947712*SINT2*(3.*COST3-COST)*CEPHI*CEPHI                     33900000
      GOTO 850                                                          33910000
 463  Y=-0.3459437*SINT3*(9.*COST2-1.)*CEPHI**3                         33920000
      GOTO 850                                                          33930000
 464  Y=1.4677149*SINT4*COST*CEPHI**4                                   33940000
      GOTO 850                                                          33950000
 465  Y=-0.4641322*SINT5*CEPHI**5                                       33960000
C                                                                       33970000
C     COMPUTES Y FOR  M .LT. 0                                          33980000
 850  IF(M.LT.0) Y=(-1)**M * CONJG(Y)                                   33990000
      RETURN                                                            34000000
C     COMPUTES Y FOR  ABS(M) .GT. L                                     34010000
 880  Y = (0.,0.)                                                       34020000
      RETURN                                                            34030000
C     STOPS PROGRAM IF ERROR IN Y-ARGUMENTS                             34040000
 890  WRITE(66,900) L,M                                                 34050000
      STOP                                                              34060000
 900  FORMAT(28H ERROR IN Y-ARGUMENTS:   L =,I3,5X,4HM = ,I3)           34070001
      END                                                               34080000
