CC ---------------------------------------------------------------------
CC Modified for AIX xlf Fortran compiler  (4/94)
CC ---------------------------------------------------------------------
CC
CC(Revised and extended 5/2002 )
CC
CC MAIN :  107 FORMAT Statements  (no more using Hollerith count)
CC         109
CC         113
CC         114
CC         115
CC         116
CC
CC         COMMON BLOCK : CHARACTER*26 CDATE
CC
CC SUBROUTINE MUSC :  3 CONTINUE (one removed)
CC                    3 CONTINUE
CC
CC SUBROUTINE MOCT :    PLOT(....) commented out
CC
CC FUNCTION RHO    :    CBRT not intrinsic so added FUNCTION CBRT
CC
CC SUBROUTINE SPACE:    RANDU not intrinsic so added SUBROUTINE RANDU
CC
CC ---------------------------------------------------------------------
C     SESH MAIN PROGRAM ( 1975, EXPERIMENTAL COPY 1994)
C
C     MANUAL: F.H. FROEHNER,
C             "SESH - A FORTRAN IV CODE FOR CALCULATING THE SELF-
C             SHIELDING AND MULTIPLE SCATTERING EFFECTS FOR
C             NEUTRON CROSS SECTION DATA INTERPRETATION
C             IN THE UNRESOLVED RESONANCE REGION",
C             REPORT GA-8380 (1968)
C
C     GILBERT-CAMERON COMPOSITE LEVEL DENSITY AND GIANT DIPOLE RESONANCE
C     MODEL ARE USED FOR THE ENERGY DEPENDENCE OF LEVEL SPACINGS AND
C     RADIATION WIDTHS IN VERSION 1975. THE INPUT REMAINS AS DESCRIBED
C     IN GA-8380 WITH TWO EXCEPTIONS: (1) THE NUCLEAR TEMPERATURE IS
C     REPLACED BY THE GILBERT-CAMERON PAIRING ENERGY OF THE COMPOUND
C     NUCLEUS, (2) ONLY THE S-WAVE LEVEL SPACING MUST BE GIVEN (SPACING
C     INPUT FOR L>0 IS IGNORED). FURTHERMORE, CHANNEL RADIUS AND
C     EFFECTIVE NUCLEAR RADIUS ARE DISTINCT FOR ALL PARTIAL WAVES:
C     THE CHANNEL RADIUS IS TAKEN AS RC(I)=(1.23*A**(1/3)+0.80) FM,
C     THE EFFECTIVE NUCLEAR RADII R(L,I) ARE INPUT NUMBERS WITH THE
C     DEFAULT VALUES R(L,I)=RC(I).
C
C     INPUT LIMITATIONS:
C             UP TO      10 ISOTOPES
C             "  "        4 PARTIAL WAVES
C             "  "        5 SAMPLE GEOMETRIES
C             "  "       24 NEUTRON ENERGIES
C             "  "   100000 MONTE CARLO HISTORIES PER ENERGY
C
      COMMON COMM(18),ZL(4),SGI(10,100),SGL(10,100,4),AP(10),UM(10),
     1A(11),AB(11),BE(11),PE(11),TEFF(11),SPIN(11),NL(10),AA(10),RC(10),
     2GG(5,11),D(5,11),S(5,11),SI(5,11),R(5,11),EFF(5,11),J2X(4,10),
     3J2N(4,10),SUMGJ(4,10),XN(6),E(100),SG(100),SP(100),SC(100),ST(100)
     4,G(8,4,10),GNR(8,4,10),GNRIN(8,4,10),DJL(8,4,10),SSCF,DSSCF,N,K,
     5I,L,J,NN,NE,NI,LX,RN(6),RX(6),ZH(100),PO,PS,DPO,DPS,ZP,SGM,STM,
     6DSGM,DSTM,TMC,DTMC,TAU,DTAU,SNC,XNSS,ITYPE,IHIST
     7,LJX(2,8,10),LJN(2,8,10),JX2(10),JN2(10),JMX(10)
      COMMON/RANDM/ IY
      DIMENSION STI(10,100),SPI(10,100),STL(10,100,4),SPL(10,100,4)
c      CHARACTER*26 CDATE
c FG051198
      CHARACTER*30 CDATE
c modification for HP on bonsai3
      open (unit=5,file='input.data',status='old')
      open (unit=8,file='output.data',status='unknown')
c end modification for HP on bonsai3
C
C             READ INPUT
C             IHIST IS A TAG FOR HISTOGRAMS OF ST, SG, T, F0;
C             IHIST=1  MEANS HISTOGRAM VALUES ARE CALCULATED AND PRINTED
C             IHIST=0  MEANS NO SUCH VALUES ARE CALCULATED OR PRINTED
C     CALL ERRSET(217,0  ,-1,1,0,100)
C     CALL ERRSET(208,300,-1,0,1,208)
      IY=4751
    1 READ(5,100,END=999)COMM,IHIST
  100 FORMAT(18A4,1I8)
      SUM=0.
      I=0
    2 I=I+1
C             I-TH ISOTOPE (MAXIMUM OF 10 ISOTOPES):
C             NUCLEON NUMBER A(I), ABUNDANCE AB(I), BINDING ENERGY BE(I) [MeV], PAIRING
C             ENERGY PE(I) [MeV], EFFECTIVE SAMPLE TEMPERATURE  TEFF(I) [DEG. K],
C             TARGET SPIN QUANTUM NUMBER SPIN(I);
      READ(5,101)A(I),AB(I),BE(I),PE(I),TEFF(I),SPIN(I)
  101 FORMAT(6E10.5)
      L=0
    3 L=L+1
C             L-TH PARTIAL WAVE (UP TO F-WAVE):
C             RADIATION WIDTH GG(L,I) [eV], AVERAGE LEVEL SPACING D(L,I) [eV], STRENGTH
C             FUNCTION FOR ELASTIC SCATTERING S(L,I), STRENGTH FUNCTION FOR
C             INELASTIC SCATTERING SI(L,I), NUCLEAR RADIUS R(L,I) [fm], DETECTION
C             EFFICIENCY
      READ(5,102)GG(L,I),D(L,I),S(L,I),SI (L,I),R(L,I),EFF(L,I)
  102 FORMAT(6E10.5)
C             CHECK FOR SAMPLE THICKNESS CARD  (FIRST WORD ZERO)
      IF(GG(L,I).EQ.0.0)GO TO 4
C             CHECK FOR LAST PARTIAL WAVE
      IF(S(L,I).LT.1.)GO TO 3
C             LAST CARD WAS ISOTOPE CARD. STORE CORRESPONDINGLY
      NL(I)=L-1
      I=I+1
      A(I)=GG(L,I-1)
      AB(I)=D(L,I-1)
      BE(I)=S(L,I-1)
      PE(I)=SI(L,I-1)
      TEFF(I)=R(L,I-1)
      SPIN(I)=EFF(L,I-1)
      GG(L,I-1)=0.
      D(L,I-1) =0.
      S(L,I-1) =0.
      SI(L,I-1)=0.
      R(L,I-1) =0.
      EFF(L,I-1)=0.
      L=0
      GO TO 3

C             LAST CARD WAS SAMPLE THICKNESS CARD (NUCLEI/B),
C             STORE CORRESPONDINGLY.

    4 NI=I
      NL(I)=L-1
      XN(1)=D(L,I)
      XN(2)=S(L,I)
      XN(3)=SI(L,I)
      XN(4)=R(L,I)
      XN(5)=EFF(L,I)
      XN(6)=0.

C             FIND NUMBER OF SAMPLE THICKNESSES
C             FOR TRANSMISSION AND CAPTURE DATA

      DO 5 N=2,6
      IF(XN(N).NE.0.)GO TO 5
      NN=N-1
      GO TO 6
    5 CONTINUE

C             READ OUTER RADII (NUCLEI/BARN)

    6 READ(5,103)(RX(N),N=1,5)
      RX(6)=0.
      IF(NN.GT.1)GO TO 8

C             FIND NUMBER OF SHELL THICKNESSES FOR SHELL TRANSMISSION
C             DATA

      DO 7 N=2,6
      IF(RX(N).NE.0.)GO TO 7
      NN=N-1
      GO TO 8
    7 CONTINUE

C             READ INNER RADII (NUCLEI/BARN) FOR SHELL TRANSMISSION
C             CALCULATIONS. RN(N)=0. MEANS CYLINDRICAL SAMPLE

    8 READ(5,103)(RN(N),N=1,5)

  103 FORMAT(E20.5,4E10.5)

C             READ NUMBER OF RESONANCE PAIRS

      READ(5,104)ZP
  104 FORMAT(E10.5)
      DO 9 M=1,25
      M4=(M-1)*4

C             READ ENERGIES (KEV) AND NUMBERS OF MONTE CARLO HISTORIES

      READ(5,105)E(M4+1),ZH(M4+1),E(M4+2),ZH(M4+2)
     *          ,E(M4+3),ZH(M4+3),E(M4+4),ZH(M4+4)
  105 FORMAT(8E10.5)

C             BLANK CARD SIGNALS END OF INPUT

      IF(E(M4+1).EQ.0.)GO TO 10
    9 CONTINUE

C             FIND NUMBER OF ENERGIES, NE

   10 DO 11 J=1,4
      MJ=M4-4+J
      IF(E(MJ).GT.0.)NE=MJ
   11 CONTINUE

C             WRITE INPUT HEADING
CC    VMS SPECIFIC DATE AND TIME PROCEDURES
c      CALL FDATE_(CDATE)
c FG051198
c modification for HP on bonsai3
c     CALL FDATE(CDATE)
c     WRITE(8,106)CDATE,COMM
c 106 FORMAT(1H1,//,'[UNIX-SESH ',A24,']     ',18A4)
c end modification for HP on bonsai3
      WRITE(8,107)
  107 FORMAT(1H0,//,
     *' I N P U T '/
     *' ========= '//
     *' NUCLEON   ABUN-    BINDING  PAIRING EFF.      NUCL.  ',
     *'ORB.ANG.  AV. RAD.    AV. LEVEL   STRENGTH    STRENGTH',
     *'    NUCLEAR     EFFI- '/
     *' NUMBER    DANCE    ENERGY   ENERGY  TEMP.     SPIN   ',
     *' MOM.     WIDTH       SPACING     FCT. FOR    FCT. FOR',
     *'    RADIUS      CIENCY'/
     *'                    (MEV)    (MEV)   (DEG.K)   Q.NO.  ',
     *' Q.NO.    (EV)        (EV)        EL. SCATT.  INEL. SC',
     *'.   (FM)              '/)

C             PREPARE ENERGY-INDEPENDENT PARAMETERS AND PRINT INPUT

      DO 16 I=1,NI

C             CHANNEL RADIUS

      RC(I)=1.23*A(I)**(1./3.)+0.8

C             GILBERT-CAMERON MATCHING ENERGY

      AI=FLOAT(INT(A(I)+1.5))
      write (6,*)'a= ',a(i),ai
      UM(I)=2.5+150./AI

C             FIND FERMI GAS MODEL A-PARAMETER FROM S-WAVE SPACING

      QI=SPIN(I)+.5
      U=BE(I)-PE(I)
      CC=ALOG(0.2367E6*AI*U/(D(1,I)*QI))
      XO=CC
      DO 12 M=1,12
      VARJ2=0.1460*XO*AI**(2./3.)
      FJ=.5*(EXP(-(QI-1.)/VARJ2)-EXP(-(QI+1.)/VARJ2))*VARJ2/QI
      XX=CC-ALOG(FJ)+2.*ALOG(XO)
      IF(ABS(XX-XO).LT.1.E-6)GO TO 13
      XO=XX
   12 CONTINUE
   13 AP(I)=XX**2/(4.*U)

C             DETERMINE MINIMUM AND MAXIMUM COMPOUND SPIN POSSIBLE

      X2I=2.*SPIN(I)
      I2=X2I+.01
      LX=NL(I)
      DO 15 L=1,LX
      J2X(L,I)=I2+2*L-1
      J2N(L,I)=1
      IF(I2.GT.2*L-2)J2N(L,I)=I2-2*L+1
      IF(I2.LT.2*L-2)J2N(L,I)=2*L-I2-3

C             CALCULATE SUM OF SPIN FACTORS

      SUMGJ(L,I)=FLOAT((J2X(L,I)+J2N(L,I)+2)*(J2X(L,I)-J2N(L,I)+2))/8./
     1(X2I+1.)

C             LEVEL DENSITY FOR GIVEN L

      IF(L.GT.1)D(L,I)=D(1,I)/SUMGJ(L,I)
      J=0
      J2MN=J2N(L,I)
      J2MX=J2X(L,I)
      DO 14 J2=J2MN,J2MX,2
      J=J+1

C             CALCULATE SPIN FACTOR

      X2J=FLOAT(J2)
      G(J,L,I)=(X2J+1.)/2./(X2I+1.)

C             LEVEL DENSITY FOR GIVEN L AND J

      DJL(J,L,I)=D(1,I)/G(J,L,I)
      ZL(L)=FLOAT(L-1)
   14 CONTINUE
      IF(R(L,I).EQ.0.)R(L,I)=RC(I)
   15 CONTINUE
      WRITE(8,108)A(I),AB(I),BE(I),PE(I),TEFF(I),SPIN(I),(ZL(L),GG(L,I)
     1,D(L,I),S(L,I),SI (L,I),R(L,I),EFF(L,I),L=1,LX)
  108 FORMAT(F6.1,F11.4,F8.3,F9.3,2F8.1,F7.0,1PE16.4,1P,4E12.4,0PF9.4/
     1                           (50X,0PF7.0,1PE16.4,1P,4E12.4,0PF9.4))
   16 CONTINUE

C             FIRST PART
C             ANALYTICAL CROSS SECTION CALCULATION FOR ALL ENERGIES
C             BEGIN K-LOOP (ENERGIES)

      DO 21 K=1,NE
      SG(K)=0.
      SC(K)=0.
      SP(K)=0.
      ST(K)=0.

C             BEGIN ISOTOPE LOOP

      DO 20 I=1,NI
      SGI(I,K)=0.
      STI(I,K)=0.
      SPI(I,K)=0.
      DO 17 L=1,4
   17 SGL(I,K,L)=0.
      AA(I)=(1.+1./A(I))**2

C             GET ENERGY DEPENDENCE FACTORS FOR LEVEL SPACINGS AND
C             RADIATION WIDTHS
C

         CALL ENDEP(E(K),A(I),BE(I),PE(I),AP(I),UM(I),EDGG,EDD)

C
C             BEGIN LOOP OF PARTIAL WAVES
      LX=NL(I)
      DO 19 L=1,LX

C             GET PENETRABILITIES, SHIFTS, HARD SPHERE PHASE SHIFTS
      AK=RC(I)*SQRT(E(K)/AA(I))/143.92

C

         CALL PEPS(AK,L,DUMMY,VL)

C

      RK=AK*R(L,I)/RC(I)

C

         CALL PEPS(RK,L,PL,DUMMY)

C
C             CALCULATE SUM OVER ALL POSSIBLE COMPOUND SPINS

      S3=0.
      J=0
      J2MN=J2N(L,I)
      J2MX=J2X(L,I)
      DO 18 J2=J2MN,J2MX,2
      J=J+1

C             FIND NUMBER OF POSSIBLE CHANNEL SPINS FOR GIVEN J AND L
      EJL=1.
      IF(J2.LT.J2X(L,I).AND.J2.GT.J2N(L,I).OR.2*L.EQ.I2+2.AND.L.NE.1.AND
     1.J2.EQ.J2N(L,I))EJL=2.

C             REDUCED WIDTHS FOR ELASTIC AND INELASTIC SCATTERING
      GNR(J,L,I)  =S(L,I) *EJL*DJL(J,L,I)
      GNRIN(J,L,I)=SI(L,I)*EJL*DJL(J,L,I)

C             NEUTRON WIDTHS FOR ELASTIC AND INELASTIC SCATTERING

      SQ=SQRT(E(K)*1000.)*VL
      GN  =GNR  (J,L,I)*SQ
      GNIN=GNRIN(J,L,I)*SQ

C             FIND PSI-FUNCTION GIVING PORTER-THOMAS AVERAGE

      ETA=SQRT((GG(L,I)*EDGG+GNIN)/(2.*GN*EDD))

C

         CALL PFCN(0.,ETA,U,V,KZ)

C

      PSI0=1.77245  *ETA*U

C             FORM J-SUM (COMPOUND SPINS)
      S3=S3+G(J,L,I)**2*(1.-PSI0)
   18 CONTINUE

C             CONTRIBUTION TO EFFECTIVE CAPTURE CROSS SECTION
      SGL(I,K,L)=4.09E3*AA(I)*AB(I)*GG(L,I)*EDGG*S3/E(K)/D(L,I)/EDD/SUMG
     1J(L,I)*EFF(L,I)

C             PURE CAPTURE CROSS SECTION

      SC(K)=SC(K)+SGL(I,K,L)/EFF(L,I)

C             CONTRIBUTION TO POTENTIAL SCATTERING CROSS SECTION

      SPL(I,K,L)=2.605E3/E(K)*AA(I)*AB(I)*(2.*FLOAT(L)-1.)*SIN(PL)**2

C             CONTRIBUTION TO TOTAL CROSS SECTION

      STL(I,K,L)=SPL(I,K,L)+4.09E6/SQRT(1000.*E(K))*AA(I)*AB(I)*S(L,I)*
     1(2.*FLOAT(L)-1.)*VL*COS(2.*PL)

C             FORM L-SUMS (PARTIAL WAVES)

      SGI(I,K)=SGI(I,K)+SGL(I,K,L)
      SPI(I,K)=SPI(I,K)+SPL(I,K,L)
      STI(I,K)=STI(I,K)+STL(I,K,L)
   19 CONTINUE

C             FORM I-SUMS (ISOTOPES)
C             AVERAGE EFFECTIVE CAPTURE CROSS SECTION, K-TH ENERGY

      SG(K)=SG(K)+SGI(I,K)

C             AVERAGE TOTAL CROSS SECTION, K-TH ENERGY

      ST(K)=ST(K)+STI(I,K)

C             POTENTIAL SCATTERING CROSS SECTION, K-TH ENERGY

      SP(K)=SP(K)+SPI(I,K)
   20 CONTINUE
   21 CONTINUE
      WRITE(8,109)
  109 FORMAT(1H0,//,
     *' A N A L Y T I C A L   R E S U L T S '/
     *' =================================== '//
     *' AVERAGE CROSS SECTIONS                               ',
     *'ISOTOPIC CONTRIBUTIONS                    PARTIAL-WAVE',
     *' CONTRIBUTIONS      '//
     *' NEUTRON   TOTAL    POTENTIAL     PURE    EFFECTIVE   ',
     *'NUCLEON  TOTAL    POTENTIAL  EFFECTIVE    L    TOTAL  ',
     *'  POTENTIAL  EFFECTIVE'/
     *'  ENERGY           SCATTERING    CAPTURE   CAPTURE    ',
     *'NUMBER           SCATTERING   CAPTURE                 ',
     *' SCATTERING   CAPTURE'/
     *'  (KEV)    (BARN)     (BARN)     (BARN)    (BARN)     ',
     *'         (BARN)     (BARN)    (BARN)           (BARN) ',
     *'    (BARN)    (BARN) ')
      DO 25 K=1,NE
      WRITE(8,110)E(K),ST(K),SP(K),SC(K),SG(K),A(1),STI(1,K),SPI(1,K),SG
     1I(1,K),STL(1,K,1),SPL(1,K,1),SGL(1,K,1)
  110 FORMAT(/,0PF7.1,1P,4E11.3,0PF7.0,1P,3E11.3,4H   0,1P,3E11.3)
      DO 24 I=1,NI
      IF(I.EQ.1)GO TO 22
      WRITE(8,111)                             A(I),STI(I,K),SPI(I,K),SG
     1I(I,K),STL(I,K,1),SPL(I,K,1),SGL(I,K,1)
  111 FORMAT(/,051X           ,0PF7.0,1P,3E11.3,4H   0,1P,3E11.3)
   22 IF(NL(I).EQ.1)GO TO 24
      LX=NL(I)
      DO 23 L=2,LX
      LL=L-1
      WRITE(8,112)LL,STL(I,K,L),SPL(I,K,L),SGL(I,K,L)
  112 FORMAT(94X,I1,1P,3E11.3)
   23 CONTINUE
   24 CONTINUE
   25 CONTINUE
C             END OF ANALYTICAL CALCULATION
      IF(ZH(1).LT.1.)GO TO 1
C             SECOND PART
C             MONTE CARLO CALCULATION OF CROSS SECTIONS AND OF
C             PROBABILITY FOR DETECTED CAPTURE
      IF(XN(1).GT.0.0.AND.RX(1).GT.0.0.AND.RN(1).EQ.0.0)ITYPO=1
      IF(XN(1).EQ.0.0.AND.RX(1).GT.0.0.AND.RN(1).GT.0.0)ITYPO=2
      IF(XN(1).GT.0.0.AND.RX(1).EQ.0.0.AND.RN(1).EQ.0.0)ITYPO=3
      IF(XN(1).GT.0.0.AND.RX(1).GT.0.0.AND.RN(1).GT.0.0)ITYPO=4
      IF(ITYPO.EQ.1)WRITE(8,113)
      IF(ITYPO.EQ.2)WRITE(8,114)
      IF(ITYPO.EQ.3)WRITE(8,115)
      IF(ITYPO.EQ.4)WRITE(8,116)
  113 FORMAT(1H1,//,
     *' M O N T E   C A R L O   R E S U L T S '/
     *' ===================================== '//
     *' CAPTURE DATA, CIRCULAR DISC SAMPLE    '//
     *' SAMPLE    NEUTRON  AV. EFF.  AVERAGE   FIRST-COLL.  P',
     *'ROB. FOR   SELF-SHIELD.  AVERAGE     NUMBER OF  NUMBER',
     *' OF  SAMPLE  AV.   '/
     *' THICK-    ENERGY   CAPTURE   TOTAL     CAPTURE      C',
     *'APTURE     CORRECTION    NUMBER OF   HISTORIES  RESONA',
     *'NCE  RADIUS  TRANS-'/
     *' NESS               CROSS     CROSS     PROBAB./     A',
     *'FTER 1     FACTOR/       COLLISIONS             PAIRS ',
     *'             MISS./'/
     *'                    SECTION/  SECTION/  UNCERT.      C',
     *'OLLISION/  UNCERT.                                    ',
     *'             UNCERT.'/
     *'                    UNCERT.   UNCERT.                U',
     *'NCERT. '/
     *' (NUC./B)   (KEV)   (B)/(B)   (B)/(B)                 ',
     *'             /(PERCENT)                               ',
     *'   (NUC./B)' )
  114 FORMAT(1H1,//,
     *' M O N T E   C A R L O   R E S U L T S '/
     *' ===================================== '//
     *' CAPTURE DATA, SPHERICAL SHELL'//
     *' SHELL     NEUTRON  AV. EFF.  AVERAGE   FIRST-COLL.  P',
     *'ROB. FOR   SHELL         AVERAGE     NUMBER OF  NUMBER',
     *' OF  SAMPLE  AV.    '/
     *' THICK-    ENERGY   CAPTURE   TOTAL     CAPTURE      C',
     *'APTURE     TRANS-        NUMBER OF   HISTORIES  RESONA',
     *'NCE  RADIUS  TRANS- '/
     *' NESS               CROSS     CROSS     PROBAB./     A',
     *'FTER 1     MISSION/      COLLISIONS             PAIRS ',
     *'             MISS./ '/
     *'                    SECTION/  SECTION/  UNCERT.      C',
     *'OLLISION/  UNCERT.                                    ',
     *'             UNCERT.'/
     *'                    UNCERT.   UNCERT.                U',
     *'NCERT. '/
     *' (NUC./B)   (KEV)   (B)/(B)   (B)/(B)                 ',
     *'                           (NUC./B)' )
  115 FORMAT(1H1,//,
     *' M O N T E   C A R L O   R E S U L T S '/
     *' ===================================== '//
     *' TRANSMISSION DATA '//
     *' SAMPLE    NEUTRON  AV. EFF.  AVERAGE   AVERAGE   SELF',
     *'-SHIELD.  NUMBER OF  NUMBER OF '/
     *' THICK-    ENERGY   CAPTURE   TOTAL     TRANS.    CORR',
     *'ECTION    HISTORIES  RESONANCE '/
     *' NESS               CROSS     CROSS     MISSION/  FACT',
     *'OR/                  PAIRS     '/
     *'                    SECTION/  SECTION/  UNCERT.   UNCE',
     *'RT. '/
     *'                    UNCERT.   UNCERT.                 ',
     *'    '/
     *' (NUC./B)   (KEV)   (B)/(B)   (B)/(B)               /(',
     *'PERCENT) ')
  116 FORMAT(1H1,//,
     *' M O N T E   C A R L O   R E S U L T S '/
     *' ===================================== '//
     *' SELF-INDICATION DATA, DISC SAMPLES '//
     *' CAPTURE   NEUTRON  AV. EFF.  AVERAGE   FIRST-COLL.  P',
     *'ROB. FOR   SELF-SHIELD.  AVERAGE     NUMBER OF  NUMBER',
     *' OF  SAMPLE  FIRST '/
     *' SAMPLE    ENERGY   CAPTURE   TOTAL     CAPTURE      C',
     *'APTURE     CORRECTION    NUMBER OF   HISTORIES  RESONA',
     *'NCE  RADIUS  SAMPLE'/
     *' THICK.             CROSS     CROSS     PROBAB./     A',
     *'FTER 1     FACTOR/       COLLISIONS             PAIRS ',
     *'             THICK.'/
     *'                    SECTION/  SECTION/  UNCERT.      C',
     *'OLLISION/  UNCERT. '/
     *'                    UNCERT.   UNCERT.                U',
     *'NCERT. '/
     *' (NUC./B)   (KEV)   (B)/(B)   (B)/(B)                 ',
     *'           /(PERCENT)                                 ',
     *'    (NUC./B) (NUC./B)')
C             DETERMINATION OF EXTREME VALUES OF L FOR EACH PARITY AND J
      DO 36 I=1,NI
      LX=NL(I)
C             TWICE EXTREME COMPOUND SPIN QUANTUM NUMBERS
      I2=2.*SPIN(I)
      JX2(I)=I2+2*LX-1
      JN2(I)=I2-2*LX+1
      IF(I2.GT.6)GO TO 26
      IF(MOD(I2,2).EQ.0)JN2(I)=1
      IF(MOD(I2,2).EQ.1)JN2(I)=0
C             JMX(I): NUMBER OF POSSIBLE J VALUES
   26 JMX(I)=(JX2(I)-JN2(I))/2+1
      JX=JMX(I)
C             J: COUNTER FOR COMPOUND SPIN IN ASCENDING ORDER
      DO 35 J=1,JX
      J2=JN2(I)+2*J-2
C             M: PARITY LABEL, M=1 FOR PARITY OF TARGET GROUND STATE
      M=1
C             EXTREMAL L VALUES FOR GIVEN PARITY, J, AND ISOTOPE
   27 IF(LX.GT.M+1)GO TO 30
      IF(J2N(M,I).LE.J2.AND.J2X(M,I).GE.J2)GO TO 29
   28 LJX(M,J,I)=-1
      LJN(M,J,I)=-1
      GO TO 34
   29 LJX(M,J,I)=M
      LJN(M,J,I)=M
      GO TO 34
   30 IF(J2N(M  ,I).LE.J2.AND.J2X(M  ,I).GE.J2)GO TO 31
      IF(J2N(M+2,I).LE.J2.AND.J2X(M+2,I).GE.J2)GO TO 33
      GO TO 28
   31 IF(J2N(M+2,I).LE.J2.AND.J2X(M+2,I).GE.J2)GO TO 32
      GO TO 29
   32 LJX(M,J,I)=M+2
      LJN(M,J,I)=M
      GO TO 34
   33 LJX(M,J,I)=M+2
      LJN(M,J,I)=M+2
   34 IF(M.GE.2)GO TO 35
      M=M+1
      IF(M.LE.LX)GO TO 27
      LJX(M,J,I)=-1
      LJN(M,J,I)=-1
   35 CONTINUE
   36 CONTINUE
C             BEGIN N-LOOP (SAMPLE THICKNESSES)
   37 DO 46 NQ=1,NN
      N=NQ
C             BEGIN K-LOOP (ENERGIES)
      DO 45 KQ=1,NE
      K=KQ
      IF(ZH(KQ).EQ.0.)GO TO 45
      IF(ZH(KQ).GT.0..AND.ZH(KQ).LT.100.)ZH(KQ)=100.
      IF(XN(N).GT.0.0 .AND. RX(N).NE.0.0 .AND. RN(N).EQ.0.0)ITYPE=1
      IF(XN(N).EQ.0.0 .AND. RX(N).NE.0.0 .AND. RN(N).NE.0.0)ITYPE=2
      IF(XN(N).GT.0.0 .AND. RX(N).EQ.0.0 .AND. RN(N).EQ.0.0)ITYPE=3
      IF(XN(N).GT.0.0 .AND. RX(N).NE.0.0 .AND. RN(N).NE.0.0)ITYPE=4
      IF(ITYPE.EQ.ITYPO)GO TO 38
      IF(ITYPE.EQ.1)WRITE(8,113)
      IF(ITYPE.EQ.2)WRITE(8,114)
      IF(ITYPE.EQ.3)WRITE(8,115)
      IF(ITYPE.EQ.4)WRITE(8,116)
      ITYPO=ITYPE
   38 CONTINUE
      GO TO (39,40,42,43),ITYPE
C
   39    CALL MUSC
C
      GO TO 41
C
   40    CALL MUSS
C
      XN(N)=RX(N)-RN(N)
   41 IF(K.EQ.1)
     *WRITE(8,117)XN(N),E(K),SGM,STM,PO,PS,SSCF,SNC, ZH(K),ZP,RX(N),
     *TMC  ,DSGM,DSTM,DPO,DPS,DSSCF,DTMC
      IF(K.GT.1)
     *WRITE(8,118)      E(K),SGM,STM,PO,PS,SSCF,SNC, ZH(K),ZP,RX(N),
     *TMC  ,DSGM,DSTM,DPO,DPS,DSSCF,DTMC
      GO TO 44
C
   42    CALL MOCT
C
      IF(K.EQ.1)
     *WRITE(8,119)XN(N),E(K),SGM,STM,TMC,TAU,ZH(K),ZP,DSGM,DSTM,DTMC,
     *DTAU
      IF(K.GT.1)
     *WRITE(8,120)      E(K),SGM,STM,TMC,TAU,ZH(K),ZP,DSGM,DSTM,DTMC,
     *DTAU
      GO TO 44
C
   43    CALL MUSC
C
      IF(K.EQ.1)
     *WRITE(8,121)XN(N),E(K),SGM,STM,PO,PS,SSCF,SNC, ZH(K),ZP,RX(N),
     *RN(N),DSGM,DSTM,DPO,DPS,DSSCF
      IF(K.GT.1)
     *WRITE(8,122)      E(K),SGM,STM,PO,PS,SSCF,SNC, ZH(K),ZP,RX(N),
     *RN(N),DSGM,DSTM,DPO,DPS,DSSCF
  117 FORMAT(' '/
     *1PE10.3,0PF7.3,1PE11.3,2E10.3,3E13.3,0P,2F10.0,1X,1P,2E10.3/
     *           17X,1PE11.3,2E10.3,2E13.3,44X        ,1P E10.3/)
  118 FORMAT(0PF17.3,1PE11.3,2E10.3,3E13.3,0P,2F10.0,1X,1P,2E10.3/
     *           17X,1PE11.3,2E10.3,2E13.3,44X        ,1P E10.3/)
  119 FORMAT(' '/
     *1PE10.3,0PF7.3,1PE11.3,2E10.3,E13.4,0P,2F11.0/
     *           17X,1PE11.3,2E10.3,E13.4/)
  120 FORMAT(0PF17.3,1PE11.3,2E10.3,E13.4,0P,2F11.0/
     *           17X,1PE11.3,2E10.3,E13.4/)
  121 FORMAT(' '/
     *1PE10.3,0PF7.3,1PE11.3,2E10.3,3E13.3,0P,2F10.0,1X,1P,2E10.3/
     *           17X,1PE11.3,2E10.3,2E13.3/)
  122 FORMAT(0PF17.3,1PE11.3,2E10.3,3E13.3,0P,2F10.0,1X,1P,2E10.3/
     *           17X,1PE11.3,2E10.3,2E13.3/)
   44 CONTINUE
   45 CONTINUE
   46 CONTINUE
      GO TO 1
  999 STOP
      END
C
      SUBROUTINE MUSC
C             MUSC  YIELDS THE MULTIPLE SCATTERING CORRECTION FOR A
C             CYLINDRICAL CAPTURE SAMPLE (MONTE CARLO)
C                XN(N)      CAPTURE SAMPLE THICKNESS
C                RX(N)      CAPTURE SAMPLE RADIUS
C                RN(N)      FILTER  SAMPLE THICKNESS
      COMMON COMM(18),ZL(4),SGI(10,100),SGL(10,100,4),AP(10),UM(10),
     1A(11),AB(11),BE(11),PE(11),TEFF(11),SPIN(11),NL(10),AA(10),RC(10),
     2GG(5,11),D(5,11),S(5,11),SI(5,11),R(5,11),EFF(5,11),J2X(4,10),
     3J2N(4,10),SUMGJ(4,10),XN(6),E(100),SG(100),SP(100),SS(100),STT(100
     4),G(8,4,10),GNR(8,4,10),GNRIN(8,4,10),DJL(8,4,10),SSCF,DSSCF,N,K,
     5I,L,J,NN,NE,NI,LX,RN(6),RX(6),ZH(100),PO,PS,DPO,DPS,ZP,SGM,STM,
     6DSGM,DSTM,TMC,DTMC,TAU,DTAU,SNC,XNSS,ITYPE,IHIST
     7,LJX(2,8,10),LJN(2,8,10),JX2(10),JN2(10),JMX(10)
      COMMON/A/ PSM(1000),POM(1000),DOP(10,10),PLE(10,4,10),GGE(10,4,10)
     1,DE(10,8,4,10),GNE(10,8,4,10),GNINE(10,8,4,10),EE(10),
     2STMC(1000),SGMC(1000),TM(1000)
      DIMENSION ZST(101),ZSG(101),ZT(101),ZF0(101),GNL(8),
     1COSE(10,4,10),SINE(10,4,10)
      IF(IHIST.NE.1)GO TO 51
      DO 50 IZ=1,101
      ZST(IZ)=0.
      ZSG(IZ)=0.
      ZT (IZ)=0.
   50 ZF0(IZ)=0.
   51 CONTINUE
      NS=1
      MM=1
      SNC=0.
      DTMC=0.
      SUM=0.
      SOM=0.
      SAM=0.
      SEM=0.
      SIM=0.
      SYM=0.
      ZSIR=0.
C     A1=(1.-EXP(-STT(K)*XN(N)))/STT(K)
C     A2=A1*SG(K)
C     IF(ITYPE.EQ.4)A1=A1*EXP(-STT(K)*RN(N))
      FE=1.-2./(A(1)*AA(1))
      DO 20 NC=1,10
      IF(NC.EQ.1)EE(NC)=E(K)
      IF(NC.GT.1)EE(NC)=EE(NC-1)*FE
      DO 20 I=1,NI
      DOP(NC,I)=SQRT(0.72531*A(I)/TEFF(I)/EE(NC))
C
         CALL ENDEP(EE(NC),A(I),BE(I),PE(I),AP(I),UM(I),EDGG,EDD)
C
      LX=NL(I)
      DO 20 L=1,LX
      GGE(NC,L,I)=GG(L,I)*EDGG
      AK=RC(I)*SQRT(EE(NC)/AA(I))/143.92
C
         CALL PEPS(AK,L,DUMMY,VL)
C
      RK=AK*R(L,I)/RC(I)
C
         CALL PEPS(RK,L,PLE(NC,L,I),DUMMY)
C
      SINE(NC,L,I)=SIN(2.*PLE(NC,L,I))
      COSE(NC,L,I)=COS(2.*PLE(NC,L,I))
      JX=(J2X(L,I)-J2N(L,I))/2+1
      DO 20 JL=1,JX
      J=(J2N(L,I)-JN2(I))/2+JL
      DE(NC,J,L,I)=DJL(JL,L,I)*EDD
      SQ=SQRT(EE(NC)*1000.)*VL*EDD
      GNE  (NC,J,L,I)=GNR  (JL,L,I)*SQ
      GNINE(NC,J,L,I)=GNRIN(JL,L,I)*SQ
   20 CONTINUE
C             BEGIN LOOP OF NEUTRON HISTORIES
      NH=ZH(K)
      NP=ZP
      DO 1 M=1,NH
C             INITIALIZE
      U=0.
      V=0.
      W=1.
      X=RX(N)*SQRT(RANDOM(D))
      Y=0.
      Z=0.
      TX=XN(N)
      NC=0
C             BEGIN OF COLLISION LOOP
    2 IF(NC.LT.10)NC=NC+1
C             FIND CROSS SECTIONS FOR COLLISION
      SN=0.
      SC=0.
      ST=SP(K)
      DO 3 I=1,NI
      JX=JMX(I)
      DO 83 J=1,JX
C             LP=1: PARITY OF TARGET GROUND STATE
C             LP=2: OPPOSITE PARITY
      DO 93 LP=1,2
      L1=LJN(LP,J,I)
      L2=LJX(LP,J,I)
      IF(L1.LT.0)GO TO 93
      JL=J-(J2N(L1,I)-JN2(I))/2
C        4.617E3=2.605E3*1.772454
      C0=4.617E3/EE(NC)*AA(I)*AB(I)*G(JL,L1,I)
C             MP: COUNTER FOR RESONANCE PAIRS
      MP=1
C             FIND CENTRAL LEVEL INTERVAL AND ENERGY IN IT
C
         CALL SPACE(DE(NC,J,L1,I),DD)
C
      H=DD*RANDOM(R)
C             FIND REDUCED NEUTRON WIDTH
   17 GNS=0.
      GNINS=0.
      DO 40 L=L1,L2,2
C
         CALL PORTER(GNE(NC,J,L,I),GNL(L))
C
      GNS=GNS+GNL(L)
   40 GNINS=GNINS+GNINE(NC,J,L,I)
      GT=GNS+GNINS+GGE(NC,L1,I)
      ETA=GT*DOP(NC,I)
      XI=2.*ETA*H/GT
      CT=C0*ETA/GT
      CG=CT*GNS*GGE(NC,L1,I)/GT
C
         CALL PFCN(XI,ETA,UU,VV,KZ)
C
      SCC=CG*UU
      SN=SN+SCC
C             EFFECTIVE CAPTURE CROSS SECTION
      SC=SC+SCC*EFF(L1,I)
C             TOTAL CROSS SECTION
      DO 41 L=L1,L2,2
   41 ST=ST+CT*GNL(L)*(UU*COSE(NC,L,I)+VV*SINE(NC,L,I))
      IF(MP.EQ.1)GO TO 18
C             CHECK IF SECOND MEMBER OF PAIR IS ALREADY INCLUDED
      IF(H.LT.0.)GO TO 16
C
         CALL WIGNER(DE(NC,J,L1,I),DD)
C
      HNEG=HNEG-DD
      H=HNEG
      GO TO 17
C             CHECK IF SECOND MEMBER OF PAIR IS ALREADY INCLUDED
   18 IF(H.LT.0.)GO TO 16
      HPOS=H
      HNEG=H-DD
      H=HNEG
      GO TO 17
C             INCLUDE ANOTHER PAIR OF RESONANCES IF REQUIRED
   16 IF(MP.EQ.NP)GO TO 93
      MP=MP+1
C
         CALL WIGNER(DE(NC,J,L1,I),DD)
C
      HPOS=HPOS+DD
      H=HPOS
      GO TO 17
   93 CONTINUE
   83 CONTINUE
    3 CONTINUE
      SN=ST-SN
      T=EXP(-TX*ST)
C             INTERACTING FRACTION
      WI=1.-T
      WG=WI*SC
C             SURVIVING FRACTION
      WN=WI*SN/ST
      IF(NC.GT.1)GO TO 6
      TF=EXP(-RN(N)*ST)
      WG=WG*TF
      WN=WN*TF
C             CALCULATE HISTOGRAM VALUES IF REQUIRED
      IF(IHIST.NE.1)GO TO 44
      IZ=20.*ST/STT(K)+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZST(IZ)=ZST(IZ)+1.
      IZ=20.*SC/SG(K)+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZSG(IZ)=ZSG(IZ)+1.
      IZ=100.*T+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZT(IZ)=ZT(IZ)+1.
      IZ=20.*(WG/ST)/(XN(N)*SG(K)*EXP(-RN(N)*STT(K)))
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZF0(IZ)=ZF0(IZ)+1.
      ZSIR=ZSIR+TF*SC
   44 CONTINUE
      POMG=WG/ST
      SOM=SOM+POMG
      PSMG=0.
C
         CALL AVERT(TM(NS),T,SGMC(NS),SC,STMC(NS),ST,NS,1)
C
      GO TO 7
    6 WG=WG/ST
      SUM=SUM+WG
      PSMG=PSMG+WG
C             PLAY RUSSIAN ROULETTE WITH SURVIVAL PROBABILITY WN
    7 IF(RANDOM(X).GT.WN)GO TO 19
C             FREE PATH SAMPLING
      FP=-ALOG(1.-WI*RANDOM(X))/ST
C             COORDINATES OF COLLISION
      X=X+U*FP
      Y=Y+V*FP
      Z=Z+W*FP
C             SCATTERING ANGLES
      PHI=6.28318 *RANDOM(D)
      CTHC=2.*RANDOM(D)-1.
      CTH=(1.+A(1)*CTHC)/SQRT(1.+A(1)**2+2.*A(1)*CTHC)
      STH=SQRT(1.-CTH**2)
C             NEW DIRECTION COSINES
      RHO=SQRT(1.-W**2)
      IF(RHO.GT.0.001)GO TO 8
      U=W*STH*COS(PHI)
      V=W*STH*SIN(PHI)
      W=W*CTH
      GO TO 9
    8 O=CTH*U+STH*(U*W*COS(PHI)-V*SIN(PHI))/RHO
      V=CTH*V+STH*(V*W*COS(PHI)+U*SIN(PHI))/RHO
      W=CTH*W-STH*COS(PHI)*RHO
      U=O
C             PATH LENGTH TO SAMPLE SURFACE
    9 B1=U**2+V**2
      B2=U*X+V*Y
      B3=RX(N)**2-X**2-Y**2
      IF(B2.LT.0.)GO TO 10
      TX=B3/(SQRT(B2**2+B1*B3)+B2)
      GO TO 11
   10 TX=(SQRT(B2**2+B1*B3)-B2)/B1
   11 IF(W.LT.-0.000001)GO TO 12
      IF(W.GT.+0.000001)GO TO 13
      GO TO 2
   12 TP=-Z/W
      GO TO 14
   13 TP=(XN(N)-Z)/W
   14 IF(TP.LT.TX)TX=TP
      GO TO 2
   19 SNC=SNC+FLOAT(NC)
C
    1    CALL AVERP(POM(MM),POMG,PSM(MM),PSMG,MM,1)
C
C             END OF HISTORY LOOP
C             MONTE CARLO RESULTS
C
         CALL AVERP(POM(MM),POMG,PSM(MM),PSMG,MM,2)
         CALL AVERT(TM(NS),T,SGMC(NS),SC,STMC(NS),ST,NS,2)
C
      TMC=0.
      SGM=0.
      STM=0.
      DO 22 M=1,NS
      TMC=TMC+TM(M)
      SGM=SGM+SGMC(M)
   22 STM=STM+STMC(M)
      TMC=TMC/FLOAT(NS)
      SGM=SGM/FLOAT(NS)
      STM=STM/FLOAT(NS)
      PO =SOM/ZH(K)
      PS =SUM/ZH(K)
      SNC=SNC/ZH(K)
      ZSIR=ZSIR/(ZH(K)*SGM)
C             STATISTICAL UNCERTAINTIES
      DO 23 M=1,NS
      DTMC=DTMC+(TM(M)-TMC)**2
      SIM=SIM+(SGMC(M)-SGM)**2
   23 SYM=SYM+(STMC(M)-STM)**2
      B11=0.
      B12=0.
      B23=0.
      BBOTH=0.
      DO 15 M=1,MM
      BBOTH=BBOTH+(POM(M)+PSM(M)-PO-PS)*(SGMC(M)-SGM)
      IF(ITYPE.EQ.4)B12=B12+(POM(M)+PSM(M)-PO-PS)*(STMC(M)-STM)
      IF(ITYPE.EQ.4)B23=B23+(STMC(M)-STM)*(SGMC(M)-SGM)
                    B11=B11+(POM(M)-PO)*(PSM(M)-PS)
      SAM=SAM+(POM(M)-PO)**2
   15 SEM=SEM+(PSM(M)-PS)**2
      DYN=FLOAT(NS*(NS-1))
      DTMC=SQRT(DTMC/DYN)
      DSGM=SQRT(SIM/DYN)
      DSTM=SQRT(SYM/DYN)
      DEN=FLOAT(MM*(MM-1))
      DPO=SQRT(SAM/DEN)
      DPS=SQRT(SEM/DEN)
      BBOTH=BBOTH/DEN
      B12=B12/DEN
      B23=B23/DEN
      B11=B11/DEN
      B11=2.*B11+DPO**2+DPS**2
C             SELF-SHIELDING CORRECTION FACTOR AND ITS PERCENT ERROR
      SSCF=(PO+PS)/(XN(N)*SGM)
      IF(ITYPE.EQ.4)EXN1=EXP(RN(N)*STM)
      IF(ITYPE.EQ.4)SSCF=SSCF*EXN1
      IF(ITYPE.EQ.1)DSSCF=SQRT(B11/(XN(N)*SGM)**2-2.*BBOTH*SSCF/(XN(N)*
     1SGM**2)+(SSCF/SGM)**2*DSGM**2)/SSCF*100.0
      IF(ITYPE.EQ.4)DSSCF=SQRT((EXN1/(XN(N)*SGM))**2*B11+2.*(EXN1/(XN(N)
     1*SGM))*RN(N)*SSCF*B12-2.*(EXN1/(XN(N)*SGM))*SSCF/SGM*BBOTH+(RN(N)*
     2SSCF*DSTM)**2-2.*RN(N)*SSCF**2/SGM*B23+(SSCF/SGM*DSGM)**2)/
     3SSCF*100.0
C             WRITE HISTOGRAM VALUES IF REQUIRED
      IF(IHIST.NE.1)GO TO 53
      SUMST=0.
      SUMSG=0.
      SUMT =0.
      SUMF0=0.
      DO 54 IZ=1,101
      SUMST=SUMST+ZST(IZ)
      SUMSG=SUMSG+ZSG(IZ)
      SUMT =SUMT + ZT(IZ)
      SUMF0=SUMF0+ZST(IZ)
   54 CONTINUE
      DO 55 IZ=1,101
      ZST(IZ)=ZST(IZ)/SUMST
      ZSG(IZ)=ZSG(IZ)/SUMSG
      ZT(IZ)=ZT(IZ)/SUMT
      ZF0(IZ)=ZF0(IZ)/SUMF0
   55 CONTINUE
      WRITE(8,198)ZSIR
  198 FORMAT(/1PE15.3/)
      WRITE(8,199)(IZ,ZST(IZ),ZSG(IZ),ZT(IZ),ZF0(IZ),IZ=1,101)
  199 FORMAT(1H1,///,' NO.      RELATIVE FREQUENCIES OF       '        /
     1               '          ST     SG     T      F0       '       //
     2(I4,0PF8.4,3F7.4))
   53 CONTINUE
      RETURN
      END
C
      SUBROUTINE MUSS
C             MUSS YIELDS THE MULTIPLE SCATTERING CORRECTION FOR A
C             SPHERICAL SHELL (MONTE CARLO)
      COMMON COMM(18),ZL(4),SGI(10,100),SGL(10,100,4),AP(10),UM(10),
     1A(11),AB(11),BE(11),PE(11),TEFF(11),SPIN(11),NL(10),AA(10),RC(10),
     2GG(5,11),D(5,11),S(5,11),SI(5,11),R(5,11),EFF(5,11),J2X(4,10),
     3J2N(4,10),SUMGJ(4,10),XN(6),E(100),SG(100),SP(100),SS(100),STT(100
     4),G(8,4,10),GNR(8,4,10),GNRIN(8,4,10),DJL(8,4,10),SSCF,DSSCF,N,K,
     5I,L,J,NN,NE,NI,LX,RN(6),RX(6),ZH(100),PO,PS,DPO,DPS,ZP,SGM,STM,
     6DSGM,DSTM,TMC,DTMC,TAU,DTAU,SNC,XNSS,ITYPE,IHIST
     7,LJX(2,8,10),LJN(2,8,10),JX2(10),JN2(10),JMX(10)
      COMMON/A/ PSM(1000),POM(1000),DOP(10,10),PLE(10,4,10),GGE(10,4,10)
     1,DE(10,8,4,10),GNE(10,8,4,10),GNINE(10,8,4,10),EE(10),
     3STMC(1000),SGMC(1000),TM(1000)
      DIMENSION ZST(101),ZSG(101),ZT(101),ZF0(101),GNL(8),
     1COSE(10,4,10),SINE(10,4,10)
      IF(IHIST.NE.1)GO TO 51
      DO 50 IZ=1,101
      ZST(IZ)=0.
      ZSG(IZ)=0.
      ZT (IZ)=0.
   50 ZF0(IZ)=0.
   51 CONTINUE
      NS=1
      MM=1
      SNC=0.
      SUM=0.
      SOM=0.
      SAM=0.
      SEM=0.
      SIM=0.
      SYM=0.
      DTMC=0.
      XNSS=RX(N)-RN(N)
      A1=(1.-EXP(-STT(K)*XNSS))/STT(K)
      A2=A1*SG(K)
      IF(ITYPE.EQ.4)A1=A1*EXP(-STT(K)*RN(N))
      FE=1.-2./(A(1)*AA(1))
      DO 20 NC=1,10
      IF(NC.EQ.1)EE(NC)=E(K)
      IF(NC.GT.1)EE(NC)=EE(NC-1)*FE
      DO 20 I=1,NI
      DOP(NC,I)=SQRT(0.72531*A(I)/TEFF(I)/EE(NC))
      LX=NL(I)
      DO 20 L=1,LX
C
         CALL ENDEP(EE(NC),A(I),BE(I),PE(I),AP(I),UM(I),EDGG,EDD)
C
      GGE(NC,L,I)=GG(L,I)*EDGG
      RK=RC(I)*SQRT(EE(NC)/AA(I))/143.92
C
         CALL PEPS(RK,L,PLE(NC,L,I),VL)
C
      PLE(NC,L,I)=PLE(NC,L,I)*R(L,I)/RC(I)
      SINE(NC,L,I)=SIN(2.*PLE(NC,L,I))
      COSE(NC,L,I)=COS(2.*PLE(NC,L,I))
      JX=(J2X(L,I)-J2N(L,I))/2+1
      DO 20 JL=1,JX
      J=(J2N(L,I)-JN2(I))/2+JL
      DE(NC,J,L,I)=DJL(JL,L,I)*EDD
      SQ=SQRT(EE(NC)*1000.)*VL*EDD
      GNE  (NC,J,L,I)=GNR  (JL,L,I)*SQ
      GNINE(NC,J,L,I)=GNRIN(JL,L,I)*SQ
   20 CONTINUE
C             BEGIN LOOP OF NEUTRON HISTORIES
      NH=ZH(K)
      NP=ZP
      DO 1 M=1,NH
C             INITIALIZE
      Q=0.
      CTH=-1.
      STH=0.
      Z=RN(N)
      TX=XNSS
      W=1.
      NC=0
C             BEGIN OF COLLISION LOOP
    2 IF(NC.LT.10)NC=NC+1
C             FIND CROSS SECTIONS FOR COLLISION
      SN=0.
      SC=0.
      ST=SP(K)
      DO 3 I=1,NI
      JX=JMX(I)
      DO 83 J=1,JX
      DO 93 LP=1,2
      L1=LJN(LP,J,I)
      L2=LJX(LP,J,I)
      IF(L1.LT.0)GO TO 93
C             4.617E3=2.605E3*1.772454
      JL=J-(J2N(L1,I)-JN2(I))/2
      C0=4.617E3/EE(NC)*AA(I)*AB(I)*G(JL,L1,I)
      MP=1
C             FIND CENTRAL LEVEL INTERVAL AND ENERGY IN IT
C
         CALL SPACE(DE(NC,J,L1,I),DD)
C
      H=DD*RANDOM(R)
   17 GNS=0.
      GNINS=0.
      DO 40 L=L1,L2,2
C             FIND REDUCED NEUTRON WIDTH
C
         CALL PORTER(GNE(NC,J,L,I),GNL(L))
C
      GNS=GNS+GNL(L)
   40 GNINS=GNINS+GNINE(NC,J,L,I)
      GT=GNS+GNINS+GGE(NC,L1,I)
      ETA=GT*DOP(NC,I)
      XI=2.*ETA*H/GT
      CT=C0*ETA/GT
      CG=CT*GNS*GGE(NC,L1,I)/GT
C
         CALL PFCN(XI,ETA,UU,VV,KZ)
C
C             CAPTURE CROSS SECTION
      SCC=CG*UU
      SN=SN+SCC
C             EFFECTIVE CAPTURE CROSS SECTION
      SC=SC+SCC*EFF(L1,I)
C             TOTAL CROSS SECTION
      DO 41 L=L1,L2,2
   41 ST=ST+CT*GNL(L)*(UU*COSE(NC,L,I)+VV*SINE(NC,L,I))
      IF(MP.EQ.1)GO TO 18
C             CHECK IF SECOND MEMBER OF PAIR IS ALREADY INCLUDED
      IF(H.LT.0.)GO TO 16
C
         CALL WIGNER(DE(NC,J,L1,I),DD)
C
      HNEG=HNEG-DD
      H=HNEG
      GO TO 17
C             CHECK IF SECOND MEMBER OF PAIR IS ALREADY INCLUDED
   18 IF(H.LT.0.)GO TO 16
      HPOS=H
      HNEG=H-DD
      H=HNEG
      GO TO 17
C             INCLUDE ANOTHER PAIR OF RESONANCES IF REQUIRED
   16 IF(MP.EQ.NP)GO TO 93
      MP=MP+1
C
         CALL WIGNER(DE(NC,J,L1,I),DD)
C
      HPOS=HPOS+DD
      H=HPOS
      GO TO 17
   93 CONTINUE
   83 CONTINUE
    3 CONTINUE
      SN=ST-SN
      T=EXP(-TX*ST)
C             INTERACTING FRACTION
      WI=1.-T
C             CAPTURED AND DETECTED FRACTION
      WG=WI*SC
      IF(ITYPE.EQ.4)WG=WG*EXP(-RN(N)*ST)
C             SURVIVING FRACTION
      WN=WI*SN/ST
      IF(NC.GT.1)GO TO 6
C             CALCULATE HISTOGRAM VALUES IF REQUIRED
      IF(IHIST.NE.1)GO TO 52
      IZ=20.*ST/STT(K)+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZST(IZ)=ZST(IZ)+1.
      IZ=20.*SC/SG(K)+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZSG(IZ)=ZSG(IZ)+1.
      IZ=100.*T+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZT(IZ)=ZT(IZ)+1.
      IZ=20.*(WG/ST)/(EXP(-XNSS*STT(K))*XNSS*SG(K))+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZF0(IZ)=ZF0(IZ)+1.
   52 CONTINUE
      POMG=WG*(1./ST-A1/WI)+A2
      SOM=SOM+POMG
      PSMG=0.
C
         CALL AVERT(TM(NS),T,SGMC(NS),SC,STMC(NS),ST,NS,1)
C
      GO TO 7
    6 WG=WG/ST
      PSMG=PSMG+WG
      SUM=SUM+WG
C             PLAY RUSSIAN ROULETTE WITH SURVIVAL PROBABILITY WN
    7 IF(RANDOM(X).GT.WN)GO TO 19
C             CALCULATE RADIAL COORDINATE (Z) OF NC-TH COLLISION
      T=-ALOG(1.-WI*RANDOM(D))/ST
      IF(T.GT.(Z*CTH-Q))  T=T+2.*Q
      Z=SQRT(Z**2+  T**2-2.*Z*  T*CTH)
C             ANGLE WITH RESPECT TO RADIUS AFTER COLLISION
      CTH=2.*RANDOM(D)-1.
      STH=SQRT(1.-CTH**2)
C             MAXIMUM PATH LENGTH IN MATTER
      Q=0.
      IF(CTH.GT.SQRT(1.-(RN(N)/Z)**2))Q=SQRT(RN(N)**2-(Z*STH)**2)
      TX=Z*CTH+SQRT(RX(N)**2-(Z*STH)**2)-2.*Q
      GO TO 2
   19 SNC=SNC+FLOAT(NC)
C
    1    CALL AVERP(POM(MM),POMG,PSM(MM),PSMG,MM,1)
C
C             END OF HISTORY LOOP
C             MONTE CARLO RESULTS
C
         CALL AVERP(POM(MM),POMG,PSM(MM),PSMG,MM,2)
         CALL AVERT(TM(NS),T,SGMC(NS),SC,STMC(NS),ST,NS,2)
C
      TMC=0.
      SGM=0.
      STM=0.
      DO 22 M=1,NS
      TMC=TMC+TM(M)
      SGM   =SGM   +SGMC(M)
   22 STM   =STM   +STMC(M)
      SGM   =SGM   /FLOAT(NS)
      TMC=TMC/FLOAT(NS)
      STM   =STM   /FLOAT(NS)
      PO=SOM/ZH(K)
      PS=SUM/ZH(K)
      SNC=SNC/ZH(K)
C             STATISTICAL UNCERTAINTIES
      DO 23 M=1,NS
      DTMC=DTMC+(TM(M)-TMC)**2
      SIM=SIM+(SGMC(M)-SGM   )**2
   23 SYM=SYM+(STMC(M)-STM   )**2
      B11=0.
      B12=0.
      B23=0.
      BBOTH=0.
      DO 15 M=1,MM
      BBOTH=BBOTH+(POM(M)+PSM(M)-PO-PS)*(SGMC(M)-SGM)
                    B11=B11+(POM(M)-PO)*(PSM(M)-PS)
      SAM=SAM+(POM(M)-PO     )**2
   15 SEM=SEM+(PSM(M)-PS     )**2
      DYN=FLOAT(NS*(NS-1))
      DTMC=SQRT(DTMC/DYN)
      DSGM   =SQRT(SIM/DYN)
      DSTM   =SQRT(SYM/DYN)
      DEN=FLOAT(MM*(MM-1))
      DPO     =SQRT(SAM/DEN)
      DPS     =SQRT(SEM/DEN)
      BBOTH=BBOTH/DEN
      B12=B12/DEN
      B11=B11/DEN
      B11=2.*B11+DPO**2+DPS**2
C             SELF-SHIELDING CORRECTION FACTOR AND ITS PERCENT ERROR
      SSCF=1.-PO-PS
      DSSCF=SQRT(DPO**2+DPS**2)
C             WRITE HISTOGRAM VALUES IF REQUIRED
      IF(IHIST.NE.1)GO TO 53
      SUMST=0.
      SUMSG=0.
      SUMT =0.
      SUMF0=0.
      DO 54 IZ=1,101
      SUMST=SUMST+ZST(IZ)
      SUMSG=SUMSG+ZSG(IZ)
      SUMT =SUMT + ZT(IZ)
      SUMF0=SUMF0+ZST(IZ)
   54 CONTINUE
      DO 55 IZ=1,101
      ZST(IZ)=ZST(IZ)/SUMST
      ZSG(IZ)=ZSG(IZ)/SUMSG
      ZT(IZ)=ZT(IZ)/SUMT
      ZF0(IZ)=ZF0(IZ)/SUMF0
   55 CONTINUE
      WRITE(8,199)(IZ,ZST(IZ),ZSG(IZ),ZT(IZ),ZF0(IZ),IZ=1,101)
  199 FORMAT(1H1,///,' NO.    TALLY FOR HISTOGRAM OF        '         /
     1               '          ST     SG     T      F0     '         //
     2(I4,0PF8.4,3F7.4))
   53 CONTINUE
      RETURN
      END
C
      SUBROUTINE MOCT
C             MOCT  YIELDS THE SELF-SHIELDING CORRECTION FACTOR AND
C             TRANSMISSION FOR A CYLINDRICAL SAMPLE
      COMMON COMM(18),ZL(4),SGI(10,100),SGL(10,100,4),AP(10),UM(10),
     1A(11),AB(11),BE(11),PE(11),TEFF(11),SPIN(11),NL(10),AA(10),RC(10),
     2GG(5,11),D(5,11),S(5,11),SI(5,11),R(5,11),EFF(5,11),J2X(4,10),
     3J2N(4,10),SUMGJ(4,10),XN(6),E(100),SG(100),SP(100),SS(100),STT(100
     4),G(8,4,10),GNR(8,4,10),GNRIN(8,4,10),DJL(8,4,10),SSCF,DSSCF,N,K,
     5I,L,J,NN,NE,NI,LX,RN(6),RX(6),ZH(100),PO,PS,DPO,DPS,ZP,SGM,STM,
     6DSGM,DSTM,TMC,DTMC,TAU,DTAU,SNC,XNSS,ITYPE,IHIST
     7,LJX(2,8,10),LJN(2,8,10),JX2(10),JN2(10),JMX(10)
      COMMON /B/ TMCG(1000),SGMC(1000),STMC(1000),DOP(10),GGE(4,10),DE(8
     1,4,10),VL(4,10),PL(4,10),EDGG(10,100),EDD(10,100),GN(8,4,10),GNIN
     2(8,4,10)
      DIMENSION TN(101),ZT(101),GNL(8),SINE(4,10),COSE(4,10)
      DIMENSION ZST(101), ZSG(101)
      MM=1
      SIM=0.
      SYM=0.
      TMC=0.
      TN(1)=1.
      ZT(1)=0.
      ZST(1)=0.
      ZSG(1)=0.
      DT=0.02
      TSUM=0.
      TNUM=0.
      TSSM=0.
      DO 2 IT=2,101
      TN(IT)=TN(IT-1)+1.
      ZST(IT)=0.
      ZSG(IT)=0.
    2 ZT(IT)=0.
      DO 20 I=1,NI
      DOP(I)=SQRT(0.72531*A(I)/TEFF(I)/E(K))
C
        CALL ENDEP(E(K),A(I),BE(I),PE(I),AP(I),UM(I),EDGG(I,K),EDD(I,K))
C
      LX=NL(I)
      DO 20 L=1,LX
      GGE(L,I)=GG(L,I)*EDGG(I,K)
      AK=RC(I)*SQRT(E(K)/AA(I))/143.92
C
         CALL PEPS(AK,L,DUMMY,VL(L,I))
C
      RK=AK*R(L,I)/RC(I)
C
         CALL PEPS(RK,L,PL(L,I),DUMMY)
C
      SINE(L,I)=SIN(2.*PL(L,I))
      COSE(L,I)=COS(2.*PL(L,I))
      JX=(J2X(L,I)-J2N(L,I))/2+1
      DO 20 JL=1,JX
      J=(J2N(L,I)-JN2(I))/2+JL
      DE(J,L,I)=DJL(JL,L,I)*EDD(I,K)
      GN  (J,L,I)=GNR  (JL,L,I)*SQRT(E(K)*1000.)*VL(L,I)*EDD(I,K)
      GNIN(J,L,I)=GNRIN(JL,L,I)*SQRT(E(K)*1000.)*VL(L,I)*EDD(I,K)
   20 CONTINUE
C             BEGIN LOOP OF NEUTRON HISTORIES
      NH=ZH(K)
      NP=ZP
      DO 1 M=1,NH
      NHIST=0
      NHIST=NHIST+1
C             FIND CROSS SECTIONS FOR COLLISION
      SN=0.
      SC=0.
      ST=SP(K)
      DO 3 I=1,NI
      JX=JMX(I)
      DO 83 J=1,JX
      DO 93 LP=1,2
      L1=LJN(LP,J,I)
      L2=LJX(LP,J,I)
      IF(L1.LT.0)GO TO 93
C             4.617E3=2.605E3*1.772454
      JL=J-(J2N(L1,I)-JN2(I))/2
      C0=4.617E3/E(K)*AA(I)*AB(I)*G(JL,L1,I)
      MP=1
C             FIND CENTRAL LEVEL INTERVAL AND ENERGY IN IT
C
         CALL SPACE(DE(J,L1,I),DD)
C
      H=DD*RANDOM(R)
   17 GNS=0.
      GNINS=0.
      DO 40 L=L1,L2,2
C             FIND REDUCED NEUTRON WIDTH
C
         CALL PORTER(GN(J,L,I),GNL(L))
C
      GNS=GNS+GNL(L)
   40 GNINS=GNINS+GNIN(J,L,I)
      GT=GNS+GNINS+GGE(L1,I)
      ETA=GT*DOP(I)
      XI=2.*ETA*H/GT
      CT=C0*ETA/GT
      CG=CT*GNS*GGE(L1,I)/GT
C
         CALL PFCN(XI,ETA,UU,VV,KZ)
C
C             CAPTURE CROSS SECTION
      SCC=CG*UU
      SN=SN+SCC
C             EFFECTIVE CAPTURE CROSS SECTION
      SC=SC+SCC*EFF(L1,I)
C             TOTAL CROSS SECTION
      DO 41 L=L1,L2,2
   41 ST=ST+CT*GNL(L)*(UU*COSE(L,I)+VV*SINE(L,I))
      IF(MP.EQ.1)GO TO 18
C             CHECK IF SECOND MEMBER OF PAIR IS ALREADY INCLUDED
      IF(H.LT.0.)GO TO 16
C
         CALL WIGNER(DE(J,L1,I),DD)
C
      HNEG=HNEG-DD
      H=HNEG
      GO TO 17
C             CHECK IF SECOND MEMBER OF PAIR IS ALREADY INCLUDED
   18 IF(H.LT.0.)GO TO 16
      HPOS=H
      HNEG=H-DD
      H=HNEG
      GO TO 17
C             INCLUDE ANOTHER PAIR OF RESONANCES IF REQUIRED
   16 IF(MP.EQ.NP)GO TO 93
      MP=MP+1
C
         CALL WIGNER(DE(J,L1,I),DD)
C
      HPOS=HPOS+DD
      H=HPOS
      GO TO 17
   93 CONTINUE
   83 CONTINUE
    3 CONTINUE
      SN=ST-SN
      T=EXP(-XN(N)*ST)
      TS=T*ST
      IF(IHIST.NE.1)GO TO 52
      IZ=20.*ST/STT(K)+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZST(IZ)=ZST(IZ)+1.
      IZ=20.*SC/SG(K)+1.
      IF(IZ.LT.1)  IZ=1
      IF(IZ.GT.101)IZ=101
      ZSG(IZ)=ZSG(IZ)+1.
   52 IZ=2.*T/DT+1.
      IF(IZ.LT.1  )IZ=1
      IF(IZ.GT.101)IZ=101
      ZT(IZ)=ZT(IZ)+1.
      TNUM=TNUM+1.
      TSUM=TSUM+T
      TSSM=TSSM+TS
C
         CALL AVERT(TMCG(MM),T,SGMC(MM),SC,STMC(MM),ST,MM,1)
C
    1 CONTINUE
C             END OF HISTORY LOOP
      AVT=TSUM/TNUM
      AVTS=TSSM/TNUM
C             MONTE CARLO RESULTS
C
         CALL AVERT(TMCG(MM),T,SGMC(MM),SC,STMC(MM),ST,MM,2)
C
      TMC=0.
      SGM=0.
      STM=0.
      DO 22 M=1,MM
      SGM=SGM+SGMC(M)
      STM=STM+STMC(M)
   22 TMC=TMC+TMCG(M )
      TMC=TMC/FLOAT(MM)
      SGM=SGM/FLOAT(MM)
      STM=STM/FLOAT(MM)
C             STATISTICAL UNCERTAINTY
      DTMC=0.
      DTS=0.
      DO 23 M=1,MM
      SIM=SIM+(SGMC(M)-SGM)**2
      SYM=SYM+(STMC(M)-STM)**2
      DTS=DTS+(STMC(M)-STM)*(TMCG(M)-TMC)
   23 DTMC=DTMC+(TMCG(M)-TMC)**2
      DEN=FLOAT(MM*(MM-1))
      DSGM=SQRT(SIM/DEN)
      DSTM=SQRT(SYM/DEN)
      DTMC=SQRT(DTMC/DEN)
      DTS2=DTS/DEN
      TAU=EXP(XN(N)*STM)*TMC
      DTAU=(XN(N)*DSTM)**2+2.*XN(N)*DTS2/TMC+(DTMC/TMC)**2
      IF(DTAU.LT.0.0)DTAU=0.0
      DTAU=100.*SQRT(DTAU)
C             WRITE HISTOGRAM VALUES IF REQUIRED
      IF(IHIST.NE.1)GO TO 53
      SUMST=0.
      SUMSG=0.
      SUMT =0.
      DO 54 IZ=1,101
      SUMST=SUMST+ZST(IZ)
      SUMSG=SUMSG+ZSG(IZ)
      SUMT =SUMT + ZT(IZ)
   54 CONTINUE
      DO 55 IZ=1,101
      ZST(IZ)=ZST(IZ)/SUMST
      ZSG(IZ)=ZSG(IZ)/SUMSG
      ZT(IZ)=ZT(IZ)/SUMT
   55 CONTINUE
      WRITE(8,199)(IZ,ZST(IZ),ZSG(IZ),ZT(IZ),IZ=1,101)
  199 FORMAT(1H1,///,' NO.    TALLY FOR HISTOGRAM OF      '           /
     1               '          ST     SG     T           '           //
     2(I4,0PF8.4,2F7.4))
C
CC     CALL PLOT(TN,ZT,100,3,3,1,1,1,1,100.,0.,0.125,100.,0.,0.125,'DISTR
CC   1IBUTION OF TRANSMISSION VALUES',1)
   53 CONTINUE
      RETURN
      END
C
      SUBROUTINE PEPS(RK,L,PL,VL)
C             PEPS CALCULATES CENTRIFUGAL-BARRIER PENETRABILITIES, VL,
C             AND HARD-SPHERE PHASE SHIFTS, PL.
      GO TO (1,2,3,4),L
    1 PL=RK
      VL=1.
      RETURN
    2 PL=RK-ATAN(RK)
      VL=RK**2/(RK**2+1.)
      RETURN
    3 PL=RK-ATAN(3.*RK/(3.-RK**2))
      VL=RK**4/(RK**4+3.*RK**2+9.)
      RETURN
    4 PL=RK-ATAN(RK*(15.-RK**2)/3./(5.-2.*RK**2))
      VL=RK**6/(RK**6+6.*RK**4+45.*RK**2+225.)
      RETURN
      END
C
      SUBROUTINE ENDEP(E,A,B,P,AP,UM,EDGG,EDD)
C             ENDEP CALCULATES THE FACTORS WHICH DESCRIBE THE ENERGY
C             DEPENDENCE OF LEVEL SPACINGS AND RADIATION WIDTHS
      DIMENSION Y1(21),Y2(21)
      E=0.001*E
      A1=A+1.
C             LEVEL DENSITY FACTOR
      U =B+E-P
      UB=B-P
      EDD=RHO(UB,A,P,AP,UM)/RHO(U,A,P,AP,UM)
C             RADIATION WIDTH FACTOR
      ER=35./A1**(1./6.)
      GR=33./A1**(1./3.)
      U1X=B+E
      U2X=B
      DO 1 N=1,21
      U1=U1X*FLOAT(N-1)/20.
      U2=U2X*FLOAT(N-1)/20.
      E1=U1X-U1
      E2=U2X-U2
      F1=(E1**2-ER**2)**2+(GR*ER)**2
      F2=(E2**2-ER**2)**2+(GR*ER)**2
      Y1(N)=E1**4*RHO(U1,A,P,AP,UM)/F1
      Y2(N)=E2**4*RHO(U2,A,P,AP,UM)/F2
    1 CONTINUE
C
         CALL SIMP(Y1,1,21,SUM1)
         CALL SIMP(Y2,1,21,SUM2)
C
      EDGG=EDD*SUM1/SUM2
      E=1000.*E
      RETURN
      END
C
      FUNCTION RHO(U,A,PE,AP,UM)
C
C         GILBERT-CAMERON COMPOSITE LEVEL DENSITY
C         (ALL SPINS AND PARITIES)
C         U:   EXCITATION ENERGY (MEV)
C         A:   ATOMIC WEIGHT OF TARGET NUCLEUS (AMU)
C         PE:  PAIRING CORRECTION (MEV)
C         AP:  A-PARAMETER (1/MEV)
C         UM:  MATCHING ENERGY (MEV)
C
      AI=FLOAT(INT(A+1.5))
      IF(U.GT.UM)GO TO 1
C         LOW ENERGIES: CONSTANT-TEMPERATURE FORMULA
      UEFF=UM-PE
      AU4=AP*UEFF*4.
      VARJ2=0.1460*SQRT(AU4)*CBRT(AI*AI)
      T=1./(SQRT(AP/UEFF)-1.5/UEFF)
      RHO=(AP/3.)*EXP(SQRT(AU4))/AU4**1.25*SQRT(2./VARJ2)
      RHO=RHO*EXP((U-UM)/T)
      RETURN
C         HIGH ENERGIES: FERMI-GAS FORMULA
    1 AU4=AP*(U-PE)*4.
      VARJ2=0.1460*SQRT(AU4)*CBRT(AI*AI)
      RHO=(AP/3.)*EXP(SQRT(AU4))/AU4**1.25*SQRT(2./VARJ2)
      RETURN
      END
C
      SUBROUTINE AVER(SGMC,SC,STMC,ST,NS,I)
      DATA N,J/100,0/
C        N   GROUP SIZE
C        I=1 SUPPLY DATA TO BE GROUPED
C        I=2 FINISH LAST GROUP,WHICH MAY CONTAIN LESS THAN N MEMBERS
      W=1./FLOAT(N)
      GO TO (1,3),I
    1 IF(J.GT.0)GO TO 2
      SGMC=0.
      STMC=0.
      J=1
    2 SGMC=SGMC+SC
      STMC=STMC+ST
      J=J+1
      IF(J.LE.N)RETURN
      J=0
      SGMC=SGMC*W
      STMC=STMC*W
      NS=NS+1
      RETURN
    3 IF(J.EQ.0)GO TO 4
      CORR=1.0/FLOAT(J-1)
      SGMC=SGMC*CORR
      STMC=STMC*CORR
      J=0
      RETURN
    4 NS=NS-1
    5 RETURN
      END
C
      SUBROUTINE AVERP(PZ,PZG,PS,PSG,MM,I)
      DATA N,J/100,0/
C        N   GROUP SIZE
C        I=1 SUPPLY DATA TO BE GROUPED
C        I=2 FINISH LAST GROUP,WHICH MAY CONTAIN LESS THAN N MEMBERS
      W=1./FLOAT(N)
      GO TO (1,3),I
    1 IF(J.GT.0)GO TO 2
      PZ=0.
      PS=0.
      J=1
    2 PZ=PZ+PZG
      PS=PS+PSG
      J=J+1
      IF(J.LE.N)RETURN
      J=0
      PZ=PZ*W
      PS=PS*W
      MM=MM+1
      RETURN
    3 IF(J.EQ.0)GO TO 4
      CORR=1.0/FLOAT(J-1)
      PZ=PZ*CORR
      PS=PS*CORR
      J=0
      RETURN
    4 MM=MM-1
    5 RETURN
      END
C
      SUBROUTINE AVERT(TM,T,SGM,SC,STM,ST,MM,I)
      DATA N,J/100,0/
C        N   GROUP SIZE
C        I=1 SUPPLY DATA TO BE GROUPED
C        I=2 FINISH LAST GROUP,WHICH MAY CONTAIN LESS THAN N MEMBERS
      W=1./FLOAT(N)
      GO TO (1,3),I
    1 IF(J.GT.0)GO TO 2
      TM=0.
      SGM=0.
      STM=0.
      J=1
    2 TM=TM+T
      SGM=SGM+SC
      STM=STM+ST
      J=J+1
      IF(J.LE.N)RETURN
      J=0
      TM=TM*W
      SGM=SGM*W
      STM=STM*W
      MM=MM+1
      RETURN
    3 IF(J.EQ.0)GO TO 4
      CORR=1.0/FLOAT(J-1)
      TM=TM*CORR
      SGM=SGM*CORR
      STM=STM*CORR
      J=0
      RETURN
    4 MM=MM-1
    5 RETURN
      END
C
      SUBROUTINE PFCN(X,Y,U,V,K)
      DATA PI,PI2,N,IS/3.14159 ,6.28318 ,5,0/
      DIMENSION EMN(10)
      IF(Y.GT.0.01)GO TO 40
      IF(IS.NE.0)GO TO 5
      IS=1
      DO 2 I=2,N
    2 EMN(I)=EXP(-FLOAT(I-1)**2)/PI
    5 CONTINUE
      XY=X/Y
      IF(1.+X*X.GT.100.*Y*Y)GO TO 30
      IF(Y.LT.0.001)GO TO 40
      Y2=Y**2
      D=X**2+Y2
      SU=Y/(D*PI)
      SV=X/(D*PI)
      DO 10 I=2,N
      AM=I-1
      XNP=X-AM
      XNM=X+AM
      DP=XNP**2+Y2
      DM=XNM**2+Y2
      SU=SU+EMN(I)*Y*(1./DP+1./DM)
      SV=SV+EMN(I)*(XNP/DP+XNM/DM)
   10 CONTINUE
      IF(Y.GT.PI)GO TO 20
      P=2.0
      IF(Y.EQ.PI)P=1.0
      XY2=X*Y*2.
      SXY2=SIN(XY2)
      CXY2=COS(XY2)
      XP2=X*PI2
      SXP2=SIN(XP2)
      CXP2=COS(XP2)
      EYP2=EXP(Y*PI2)
      EYX=EXP(Y2-X**2)
      D=1.-2.*EYP2*CXP2+EYP2**2
      SU=SU+P*EYX*(CXY2-EYP2*(CXP2*CXY2+SXP2*SXY2))/D
      SV=SV-P*EYX*(SXY2+EYP2*(SXP2*CXY2-CXP2*SXY2))/D
   20 U=SU
      V=SV
      RETURN
   30 F=1.77245  *Y
      U=1./((1.+XY**2)*F)
      V=XY*U
      RETURN
C
   40    CALL PFCNP(X,Y,U,V,K)
C
      RETURN
      END
C
      SUBROUTINE PFCNP(X,Y,U,V,L)
C
C     PFCN YIELDS REAL AND IMAGINARY PART OF THE COMPLEX
C     PROBABILITY INTEGRAL
C
      DIMENSION W287(4),W283(4)
      DATA W283/1.65068,.524648,-.524648,-1.65068/
      DATA W287/.025883,.256212,.256212,.025883/
      II=1
      ASSIGN 244 TO J
      C5=X
      C6=Y
      IF(C5.LT.0.0)GO TO 8
      IF(C6.LT.0.0)GO TO 287
      GO TO 11
    8 IF(C6.GE.0.0)GO TO 14
      ASSIGN 245 TO I
      GO TO 20
   11 ASSIGN 257 TO I
      GO TO 46
   14 ASSIGN 255 TO I
      GO TO 46
   20 Z=C6*C6-C5*C5
      CO=EXP(Z)
      C7=CO+CO
      CO=C5*C6
      C9=CO+CO
      C8=-C7*SIN(C9)
      C7=C7*COS(C9)
   46 C5=ABS(C5)
      C6=ABS(C6)
      IF(C5.GE.6.0)GO TO 219
   50 IF(C6.LE.0.5)GO TO 65
      IF(C6.LE.3.0)GO TO 61
      IF(C6.GT.6.0)GO TO 219
      C9=0.5
      GO TO 73
   61 IF(C6.LE.1.5)GO TO 71
      C9=0.25
      GO TO 73
   65 C10=C6
      C6=0.5
      ASSIGN 128 TO J
   71 C9=0.09375
   73 C11=0.0
      C17=0.0
      C18=0.0
      ASSIGN 123 TO K
   79 C21=C5-C11
      C19=C21*C21
      C20=C6*C6+C19
      T=C11*C11
      C19=EXP(-T)/C20*0.31830*C9
      C17=C19*C6+C17
      C18=C21*C19+C18
  107 GO TO K,(108,123)
  108 II=3-II
      IF(II.EQ.1)GO TO 114
      C11=-C11
      GO TO 79
  114 IF(-C11-4.0.GT.0.0)GO TO J,(128,244)
      C11=-C11+C9
      GO TO 79
  123 II=1
      ASSIGN 108 TO K
      C11=C9
      GO TO 79
  128 C11=C17
      C12=C18
      C9=2.0
      C6=C10-0.5
      C6=C6+C6
      C10=C11/2.0
      C13=(C5*C12+C10-0.56419)*C6
      C10=C12/2.0
      C14=(-C5*C11+C10)*C6
      C17=C11+C13
      C18=C12+C14
  165 C10=C6/C9
      C19=C13/2.0
      C19=C5*C14+C19
      C15=(C6/2.0*C11+C19)*C10
      C17=C15+C17
      T1=C5*C13
      C19=(C6*C12+C14)/2.0
      C16=(-T1+C19)*C10
      C18=C16+C18
      T1=C17+C15
      IF((T1-C17).NE.0.0)GO TO 207
      T1=C18+C16
      IF((T1-C18).EQ.0.0)GO TO 244
  207 C11=C13
      C12=C14
      C13=C15
      C14=C16
      C9=C9+1.0
      GO TO 165
  219 C17=0.0
      C18=0.0
      DO 230 M=1,4
      C12=C5-W283(M)
      C11=C12*C12
      C11=C6*C6+C11
      C11=W287(M)/C11
      C17=C11*C6+C17
      C18=C11*C12+C18
  230 CONTINUE
  244 GO TO I,(245,249,255,257)
  245 C8=-C8
      C18=-C18
  249 C17=C7-C17
      C18=C8-C18
  255 C18=-C18
  257 U=C17
      V=C18
      L=0
      RETURN
  287 C5=-C5
      ASSIGN 249 TO I
      GO TO 20
      END
C
      SUBROUTINE WIGNER(DAV,D)
C             WIGNER YIELDS LEVEL SPACINGS WITH THE WIGNER DISTRIBUTION.
C             DAV IS THE AVERAGE LEVEL SPACING.
    1 WWW=RANDOM(A)
      IF(WWW.EQ.0.) GO TO 1
      D=1.12837  *DAV*SQRT(-ALOG(WWW))
      RETURN
      END
C
      SUBROUTINE PORTER(GNAV,GN)
C             PORTER YIELDS NEUTRON WIDTHS WITH THE PORTER-THOMAS
C             DISTRIBUTION. GNAV IS THE AVERAGE WIDTH.
C             V. NEUMANN SCHEME
    1 R=RANDOM(D)*0.929
      RR=1./(1.-R)**2
      X=R**2*RR
      IF(X.GT.170.) GO TO 1
      IF(RANDOM(D).GT.0.560*EXP(-X)*RR)GO TO 1
      GN=2.*GNAV*X
      RETURN
      END
C
      SUBROUTINE SPACE(DAV,D)
C             SPACE YIELDS LEVEL SPACINGS WITH A D-WEIGHTED WIGNER
C             DISTRIBUTION. DAV IS THE AVERAGE OF THE WIGNER DISTRIBU-
C             TION. V. NEUMANN SCHEME
    1 R=RANDOM(A)
      X=(R/(1.-R))**0.3333
      IF(X.GT.13.) GO TO 1
      IF(RANDOM(A).GT.0.494*EXP(-X**2)/(1.-R)**2)GO TO 1
      D=1.12837  *DAV*X
      RETURN
      END
      FUNCTION RANDOM(DUMMY)
      COMMON/RANDM/ IY
      DATA EPS/1.E-15/
      IX=IY
C
         CALL RANDU(IX,IY,RA)
C
      IF(RA.LT.EPS)RA=EPS
      RANDOM=RA
      RETURN
      END
C
      SUBROUTINE SIMP(Y,M,N,SUM)
C
C         SIMPSON'S RULE
C
      DIMENSION Y(21)
      SUM=0.
      K1=M+1
      K2=N-1
      DO 1 K=K1,K2,2
    1 SUM=SUM+Y(K-1)+4.*Y(K)+Y(K+1)
      SUM=SUM/3.
      RETURN
      END
C
      FUNCTION CBRT(MANT)
C
      EXPO=1./3.
      CBRT=MANT**EXPO
      RETURN
      END
C
C
C
C        SUBROUTINE RANDU
C
C        PURPOSE
C           COMPUTES UNIFORMLY DISTRIBUTED RANDOM REAL NUMBERS BETWEEN
C           0 AND 1.0 AND RANDOM INTEGERS BETWEEN ZERO AND
C           2**31. EACH ENTRY USES AS INPUT AN INTEGER RANDOM NUMBER
C           AND PRODUCES A NEW INTEGER AND REAL RANDOM NUMBER.
C
C        USAGE
C           CALL RANDU(IX,IY,YFL)
C
C        DESCRIPTION OF PARAMETERS
C           IX - FOR THE FIRST ENTRY THIS MUST CONTAIN ANY ODD INTEGER
C                NUMBER WITH NINE OR LESS DIGITS. AFTER THE FIRST ENTRY,
C                IX SHOULD BE THE PREVIOUS VALUE OF IY COMPUTED BY THIS
C                SUBROUTINE.
C           IY - A RESULTANT INTEGER RANDOM NUMBER REQUIRED FOR THE NEXT
C                ENTRY TO THIS SUBROUTINE. THE RANGE OF THIS NUMBER IS
C                BETWEEN ZERO AND 2**31
C           YFL- THE RESULTANT UNIFORMLY DISTRIBUTED, FLOATING POINT,
C                RANDOM NUMBER IN THE RANGE 0 TO 1.0
C
C        REMARKS
C           THIS SUBROUTINE IS SPECIFIC TO SYSTEM/360 AND WILL PRODUCE
C           2**29 TERMS BEFORE REPEATING.  THE REFERENCE BELOW DISCUSSES
C           SEEDS (65539 HERE), RUN PROBLEMS, AND PROBLEMS CONCERNING
C           RANDOM DIGITS USING THIS GENERATION SCHEME.  MACLAREN AND
C           MARSAGLIA, JACM 12, P. 83-89, DISCUSS CONGRUENTIAL
C           GENERATION METHODS AND TESTS.  THE USE OF TWO GENERATORS OF
C           THE RANDU TYPE, ONE FILLING A TABLE AND ONE PICKING FROM THE
C           TABLE, IS OF BENEFIT IN SOME CASES.  65549 HAS BEEN
C           SUGGESTED AS A SEED WHICH HAS BETTER STATISTICAL PROPERTIES
C           FOR HIGH ORDER BITS OF THE GENERATED DEVIATE.
C           SEEDS SHOULD BE CHOSEN IN ACCORDANCE WITH THE DISCUSSION
C           GIVEN IN THE REFERENCE BELOW.  ALSO, IT SHOULD BE NOTED THAT
C           IF FLOATING POINT RANDOM NUMBERS ARE DESIRED,AS ARE
C           AVAILABLE FROM RANDU, THE RANDOM CHARACTERISTICS OF THE
C           FLOATING POINT DEVIATES ARE MODIFIED AND IN FACT THESE
C           DEVIATES HAVE HIGH PROBABILITY OF HAVING A TRAILING LOW
C           ORDER ZERO BIT IN THEIR FRACTIONAL PART.
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           POWER RESIDUE METHOD DISCUSSED IN IBM MANUAL C20-8011,
C           RANDOM NUMBER GENERATION AND TESTING
C
C     ..................................................................
C
      SUBROUTINE RANDU(IX,IY,YFL)
      IY=IX*65539
      IF(IY)5,6,6
    5 IY=IY+2147483647+1
    6 YFL=IY
      YFL=YFL*.4656613E-9
      RETURN
      END


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

module gfdb_build_

    use util
    use unit
    use gfdb
    use better_varying_string
    use sparse_trace
    use read_table
    use seismogram_io

    implicit none

    private
    public addentry, set_database, close_database

    type(t_gfdb), save :: db
    integer :: traces_added = 0
    integer, dimension(2) :: last_span = (/1,1/)

  contains

    subroutine set_database( basefn, nchunks, nx,nz,ng, dt,dx,dz, firstx, firstz )

        type(varying_string), intent(in) :: basefn
        integer, intent(in), optional :: nchunks, nx,nz,ng
        real, intent(in), optional :: dt, dx, dz
        real, intent(in), optional :: firstx, firstz

        if (present(nchunks) .and. present(nx) .and. present(nz) .and. &
            present(ng) .and. present(dt) .and. present(dx) .and. present(dz)) then
            call gfdb_init(db, basefn, nchunks, nx,nz,ng, dt,dx,dz, firstx, firstz )
        else
            call gfdb_init(db, basefn)
        end if

    end subroutine

    subroutine close_database()
        call gfdb_destroy( db )
    end subroutine

    subroutine addentry( buffer, ok )

        character(len=*), intent(in) :: buffer
        logical, intent(out)         :: ok

        character(len=len(buffer)), dimension(max(1,(count_words(buffer)-3))) :: filename

        real, dimension(:), allocatable :: seismogram
        real(kind=8) :: toffset
        real :: deltat
        integer :: ig, ifile, nfiles, ioffset, iostat, ix, iz, nerr
        real :: x, z
        type(t_strip) :: conti
        type(t_trace) :: tr, trold, tr2
        integer, dimension(2) :: span

        nfiles = size(filename)

        read (unit=buffer,fmt=*,iostat=iostat) x, z, ig, &
                                               (filename(ifile), ifile=1,nfiles)
        if (iostat == 0) then
            ok = .true.

            do ifile=1,nfiles
                call readseismogram(trim(filename(ifile)), "*", seismogram, toffset, deltat, nerr )

                if (nerr /= 0) call die( "can't read file '" &
                                                // var_str(filename(ifile)) // "'" )

                if (abs(deltat - db%dt) > db%dt / 10000.) then
                    call die( "sampling rate of file does not match sampling rate of gfdb: '" &
                                               // var_str(filename(ifile)) // "'" )
                end if

              ! convert seismogram => strip
                ioffset = nint(toffset/db%dt) + 1

                span(1) = ioffset
                span(2) = ioffset+size(seismogram)-1
                call strip_init( span, seismogram, conti )

              ! pack strip => sparse trace
                if (ifile == 1) then
                    if (traces_added > 1) then
                        call trace_pack( conti, tr, last_span )
                    else
                        call trace_pack( conti, tr )
                    end if
                else
                    if (traces_added > 1) then
                        call trace_pack( conti, tr2, last_span )
                    else
                        call trace_pack( conti, tr2 )
                    end if
                    call trace_copy( tr, trold )   ! horribly inefficient...
                    call trace_join( trold, tr2, tr )
                end if

            end do

          ! put in database

            call gfdb_get_indices( db, x, z, ix, iz )
            call gfdb_save_trace( db, ix, iz, ig, tr )
            traces_added = traces_added + 1

            last_span = tr%span

          ! periodically close the gfdb, so that hdf is forced to deallocate
          ! all it's memory
            if (traces_added > 1000) then
                call gfdb_close( db )
                traces_added = 0
            end if

            do ifile=1,nfiles
                print *, filename(ifile)
                call flush(stdout)

            end do
        end if

        call strip_destroy( conti )
        call trace_destroy( tr )
        call trace_destroy( tr2 )
        call trace_destroy( trold )

    end subroutine

end module

program gfdb_build

  ! This program is used to create and fill a Greens function database to be used with the kiwi programs.
  !
  ! usage: gfdb_build database [ nchunks nx nz ng dt dx dz [ firstx firstz ] ] <<EOF
  ! x z ig 'filename1' ...
  ! ...
  ! EOF
  !
  ! Complete documentation is available on
  !
  !   http://kinherd.org/power/trac/wiki/GFDBBuildTool
  !

    use util
    use better_varying_string
    use varying_string_getarg
    use read_line
    use gfdb_build_

    ! use f90_unix_env

    implicit none

    integer              :: nchunks, nx, nz, ng
    real                 :: dt, dx, dz
    real                 :: firstx, firstz
    type(varying_string) :: basefn
    integer              :: iostat, iline
    logical              :: ok
    character, parameter :: eol = char(10)

    g_pn = 'gfdb_build'
    g_usage = 'usage: ' // g_pn // ' database [ nchunks nx nz ng dt dx dz [ firstx firstz ] ] <<EOF' // eol // &
              "x z ig 'filename1' ..." // eol // &
              "..." // eol // &
              "EOF" // eol // eol // &
              "documentation:  " // &
              "http://kinherd.org/power/trac/wiki/GFDBBuildTool"

    if (iargc() /= 10 .and. iargc() /= 8 .and. iargc() /= 1) call usage()

    call vs_getarg( 1, basefn )
    if (iargc() == 8 .or. iargc() == 10) then
        call int_getarg( 2, 1, huge(nchunks), nchunks )
        call int_getarg( 3, 1, huge(nx), nx )
        call int_getarg( 4, 1, huge(nz), nz )
        call int_getarg( 5, 1, huge(ng), ng )
        call real_getarg( 6, tiny(dt), huge(dt), dt )
        call real_getarg( 7, tiny(dx), huge(dx), dx )
        call real_getarg( 8, tiny(dz), huge(dz), dz )
        firstx = 0.
        firstz = 0.
        if (iargc() == 10) then
            call real_getarg(  9, -huge(firstx), huge(firstx), firstx )
            call real_getarg( 10, -huge(firstz), huge(firstz), firstz )
        end if
        call set_database( basefn, nchunks, nx,nz,ng, dt,dx,dz, firstx, firstz )
    else
        call set_database( basefn )
    end if

    iline = 1
    line_loop : do
        call readline( addentry, iostat, ok )
        if (iostat == IOSTAT_EOF) exit line_loop
        if (.not. ok) call die( "gfdb_build: reading line "// iline &
                                 //" from standard input failed." )
        iline = iline+1
    end do line_loop

    call close_database()

    call cleanup()

end program


!====================================================================================================
!
! File:    corpse_variable.f90
!
! Purpose: defines/allocates variables for CORPSE model
!
!   MODULE corpsedimension
!   MODULE corpsevariable with subroutine alloc_corpsesvariable
!
! Contact: Melannie Hartman
!          melannie@ucar.edu
!
! History:
!          12/28/2015 - Created
!          01/04/2016 - Compiled
!====================================================================================================

MODULE corpsedimension

    implicit none

    !Carbon species: Labile (1), Recalcitrant (2), and Dead microbe C (3)
    integer,parameter::LABILE=1
    integer,parameter::RECALCTRNT=2
    integer,parameter::DEADMICRB=3
    integer,parameter::nspecies=3

    !Maximum number of soil layers
    integer,parameter::max_lev=2
    integer,parameter::num_lyr=1     !Number of soil layers

    real,parameter::DENS_H2O=1000.0
    real,parameter::layerThickness=0.15
    !!integer, parameter :: NHOURS = 24  ! Number of time steps per day when running hourly

END MODULE corpsedimension
!====================================================================================================

MODULE corpsevariable

    USE corpsedimension
    USE corpse_soil_carbon

    implicit none

    !Data container to store all the outputs while it runs
    !nlines = number of timesteps written to output file
    type outputvars
        real,allocatable :: litterC(:,:)          ! dimensions nspecies, nlines
        real,allocatable :: protectedC(:,:)       ! dimensions nspecies, nlines
        real,allocatable :: livingMicrobC(:)      ! dimension nlines
        real,allocatable :: CO2(:)                ! dimension nlines
        real,allocatable :: totalC(:)             ! dimension nlines
        real,allocatable :: Rtot(:,:)             ! dimensions nspecies, nlines
        real,allocatable :: protectedProd(:,:)    ! dimensions nspecies, nlines
        real,allocatable :: Ts(:)                 ! dimension nlines
        real,allocatable :: thetaLiq(:)           ! dimension nlines
        real,allocatable :: thetaFrzn(:)          ! dimension nlines
        real,allocatable :: fT(:)                 ! dimensions nlines (Placeholder, not currently written to output -mdh 11/27/2017)
        real,allocatable :: fW(:)                 ! dimensions nlines
        real,allocatable :: time(:)               ! dimension nlines
        real             :: cwd2co2(366)          ! dimension 1..days in a year (added 2/6/2017)
        integer :: linesWritten=0
        integer,allocatable::ncohorts(:)
        ! Annual means for the simulation (added 3/28/2016)
        ! These are updated in subroutine corpse_caccum.
        integer :: nYear=0                        ! counter for current year being simulated
        real,allocatable :: litterCan(:,:)        ! dimensions nspecies, nlines
        real,allocatable :: protectedCan(:,:)     ! dimensions nspecies, nlines
        real,allocatable :: livingMicrobCan(:)    ! dimensions nlines
        real,allocatable :: CO2an(:)              ! dimensions nlines
        real,allocatable :: totalCan(:)           ! dimensions nlines
        real,allocatable :: TsAn(:)               ! dimensions nlines
        real,allocatable :: thetaLiqAn(:)         ! dimensions nlines
        real,allocatable :: thetaFrznAn(:)        ! dimensions nlines
        real,allocatable :: fTAn(:)               ! dimensions nlines (Placeholder, not currently written to output -mdh 11/27/2017)
        real,allocatable :: fWAn(:)               ! dimensions nlines
        real,allocatable :: timeAn(:)             ! dimensions nlines
    end type outputvars

    !Grid cell type to hold all grid-cell specific values
    type gridcell
        real,allocatable,dimension(:):: dz, z                    ! Soil layer thickness and depth (m) (dimension = # of soil layers, num_lyr)
        type(soil_carbon_pool),dimension(:),allocatable:: soil   ! CORPSE soil carbon pool array representing soil layers (dimension = # of soil layers, num_lyr)
        type(soil_carbon_pool):: litterlayer                     ! CORPSE soil carbon pool representing the litter layer
        type(outputvars),dimension(:),allocatable:: soil_outputs ! Container for output variables (dimension = # of soil layers, num_lyr)
        type(outputvars):: litterlayer_outputs                   ! Container for output variables
        ! Variables for storing diagnostic values generated by the update_pool subroutine
        real:: fast_C_loss_rate
        real:: slow_C_loss_rate
        real:: deadmic_C_loss_rate
        real:: CO2prod
        real:: deadmic_produced
        real,dimension(nspecies):: protected_produced
        real,dimension(nspecies):: protected_turnover_rate
        real,dimension(nspecies):: C_dissolved,deposited_C
    end type gridcell

    !Holds the netcdf variable identifiers
    type ncvars
        integer :: dimid_time,dimid_species,dimid_depth,dimid_lat,dimid_lon  ! NetCDF dimension ids
        integer :: lonid, latid              ! NetCDF variable ID for latitude and longitude
        integer :: timeid                    ! NetCDF variable ID for simulation time (years)
        integer :: dayid                     ! NetCDF variable ID for simulation day of year
        integer :: soilProtectedCid(nspecies)! NetCDF variable ID for protected soil carbon
        integer :: soilCid(nspecies)         ! NetCDF variable ID for unprotected soil carbon
        integer :: litterCid(nspecies)       ! NetCDF variable ID for unprotected litter layer carbon
        integer :: Tsid                      ! NetCDF variable ID for soil temperature
        integer :: thetaLiqid                ! NetCDF variable ID for liquid soil moisture
        integer :: thetaFrznid               ! NetCDF variable ID for frozen soil moisture
!       integer :: fTid                      ! NetCDF variable ID for liquid soil moisture
        integer :: fWid                      ! NetCDF variable ID for frozen soil moisture
        integer :: soil_livingMicrobeid      ! NetCDF variable ID for living soil microbe carbon
        integer :: litter_livingMicrobeid    ! NetCDF variable ID for living litter layer microbe carbon
        integer :: soil_CO2id                ! NetCDF variable ID for soil heterotrophic respiration C
        integer :: litter_CO2id              ! NetCDF variable ID for litter layer heterotrophic respiration C
        integer :: ncohortsid                ! NetCDF variable ID for number of cohorts in the litter or soil pool
        integer :: litter_totalCid           ! NetCDF variable ID for total carbon in litter layer
        integer :: soil_totalCid             ! NetCDF variable ID for total carbon in soil layer
        integer :: depthid                   ! NetCDF variable ID for soil depth (meters)
        integer :: cellid                    ! NetCDF variable ID for for cellid(nlon,nlat)
        integer :: landareaid                ! NetCDF variable ID for land area
        integer :: maskid                    ! NetCDF variable ID for cellMissing(nlon,nlat)
        integer :: igbpid                    ! NetCDF variable ID for IGBP_PFT(nlon,nlat)

        !! Currently unused IDs
        integer :: Rtotid                    ! NetCDF variable ID for
        integer :: protectedProdid           ! NetCDF variable ID for
        integer :: leachingid                ! NetCDF variable ID for
        integer :: litterleachingid          ! NetCDF variable ID for
        integer :: leaching_divergenceid     ! NetCDF variable ID for
        integer :: flowid                    ! NetCDF variable ID for
        integer :: DOCid                     ! NetCDF variable ID for
        integer :: litterlayerDOCid          ! NetCDF variable ID for
    end type ncvars
    type(ncvars)::varids
    integer::ncid_corpse

    integer::namelistunit=123

    !Parameters for this test model run, in namelist file
    namelist /CORPSE_casa_nml/ initial_C, &
                               exudate_npp_frac, &
                               rhizosphere_frac, &
                               litter_option

    real:: initial_C(nspecies)             ! initial carbon pools for litter and soil layers
    !!real:: annual_exudate_input(nspecies)
    real:: exudate_npp_frac(nspecies)
    real:: rhizosphere_frac
    integer:: litter_option
    real::T           !soil temperature (K)

    integer::recordtime  !How often to record output data (# of timestep(hours))
    !!integer::maxSteps  !Maximum number of CORPSE time steps in the simulation.
                         !This is now computed by CASA as total number of simulation years * 365 * #timesteps per day.
                         !It is used only to dimension output variables
    integer::timestep    !What time step the model is on (# of timesteps)
    real:: dt            !timestep in years (1/(24*365) for hourly timestep, 1/365 for daily timestep)

    type(gridcell),dimension(:),allocatable:: pt

    integer:: verbose = 0

    real, parameter :: MISSING_VALUE = 1.e+36
    integer, parameter :: MISSING_INT = -9999

    character(len=100) :: filename_corpsenamelist !! file CORPSE namelist parameter file
    character(len=100) :: sPtFileNameCORPSE
    integer :: iptToSave_corpse

CONTAINS

!----------------------------------------------------------------------------------------------------
! Allocate memory for allocatable dimensions.
! These include the number of grid cells and the number of soil layers per grid cell.
!
SUBROUTINE alloc_corpsevariable(mp)
    USE corpsedimension
    implicit none
    integer, INTENT(IN) :: mp    ! number of grid points

    ! Local Variables
    integer::ipt, jj

    !Allocate memory for the grid of mp points
    allocate(pt(mp))

    do ipt = 1, mp
        ! Allocate memory for the number of soil layers.
        ! There is always only one litter layer per grid cell so that does not require allocation.
        allocate(pt(ipt)%z(num_lyr))
        allocate(pt(ipt)%dz(num_lyr))
        allocate(pt(ipt)%soil(num_lyr))
        allocate(pt(ipt)%soil_outputs(num_lyr))

        pt(ipt)%dz=layerThickness      !Soil layer thickness (constant in this case, but can vary between layers)
        pt(ipt)%z=0.0
        ! Calculate soil layer levels based on thickness of each layer
        if (num_lyr > 1) then
            print *, 'Uncomment the code for num_lyr > 1 alloc_corpsevariable'
            stop
        !   do jj=2,num_lyr
        !       pt(ipt)%z(jj) = pt(ipt)%z(jj-1) + pt(ipt)%dz(jj-1)
        !   enddo
        endif
    enddo

END SUBROUTINE alloc_corpsevariable

END MODULE corpsevariable
!====================================================================================================


MODULE hamiltonian_module

  use parallel_module, only: myrank
  use kinetic_module
  use localpot_module
  use nonlocal_module
  use fock_module
  use watch_module

  implicit none

  PRIVATE
  PUBLIC :: hamiltonian,op_kinetic,op_localpot,op_nonlocal &
           ,ctt_hamil,ett_hamil

  real(8) :: ctt_hamil(4),ett_hamil(4)

CONTAINS

  SUBROUTINE hamiltonian(k,s,tpsi,htpsi,n1,n2,ib1,ib2)
    implicit none
    integer,intent(IN) :: k,s,n1,n2,ib1,ib2
#ifdef _DRSDFT_
    real(8),intent(IN)  :: tpsi(n1:n2,ib1:ib2)
    real(8),intent(OUT) :: htpsi(n1:n2,ib1:ib2)
#else
    complex(8),intent(IN)  :: tpsi(n1:n2,ib1:ib2)
    complex(8),intent(OUT) :: htpsi(n1:n2,ib1:ib2)
#endif
    real(8) :: ttmp(2)

!$OMP parallel

!$OMP workshare
    htpsi=(0.d0,0.d0)
!$OMP end workshare

    call watchb_omp( ttmp )

! --- Kinetic energy ---

    call op_kinetic(k,tpsi,htpsi,n1,n2,ib1,ib2)

!$OMP barrier

    call watchb_omp( ttmp, time_hmlt(1,1) )

! --- local potential ---

    call op_localpot(s,n2-n1+1,ib2-ib1+1,tpsi,htpsi)

!$OMP barrier

    call watchb_omp( ttmp, time_hmlt(1,2) )

! --- nonlocal potential ---

    call op_nonlocal(k,s,tpsi,htpsi,n1,n2,ib1,ib2)

!$OMP barrier

    call watchb_omp( ttmp, time_hmlt(1,3) )

!$OMP end parallel

    call watchb( ttmp )

    call op_fock(k,s,n1,n2,ib1,ib2,tpsi,htpsi)

    call watchb( ttmp, time_hmlt(1,4) )

  END SUBROUTINE hamiltonian

END MODULE hamiltonian_module


      subroutine read_env_gamess(orb_info)

      implicit none

      include 'ioparam.h'
      include 'stdunit.h'
      include 'def_filinf.h'
      include 'def_orbinf.h'
      include 'ifc_baserout.h'
      include 'par_gamess.h'
      include 'ifc_input.h'

      integer, parameter ::
     &     ntest =  00
      real(8), parameter ::
     &     thr_auto_freeze = -2.5d0

      type(orbinf) ::
     &     orb_info

      type(filinf) ::
     &     ffdict

      integer, parameter ::
     &     mxsym = 8
      integer ::
     &     ludict, iprint, ngas, idx, jdx, nspin, nsym, isym,
     &     mxirrep, lsym, nactel, ispin, nstate, igroup,
     &     nfro(mxsym), nrhf(mxsym), nash(mxsym), norb(mxsym)
      logical ::
     &     isgroup(8)
      character(3) ::
     &     groups(8), irreps(8)

      ! 64 bit version of GAMESS writes integer*8
      integer(8) ::
     &     irecst,ioda(len_da),ifilen(len_da),is,ipk,
     &     nfroz,nocct,n_act,norbs,norbt,num1
      real(8) ::
     &     potnuc,emcscf,sz,s2,etot2,eerd,e1,e2,ven,vee,epot,
     &     eelct,ekin,estate(mxrt),statn,ecore

      real(8), pointer ::
     &     orb_en(:)
      integer(8), pointer ::
     &     orb_sym(:)
      character(len=8), pointer ::
     &     orb_lab(:)

      groups(1:8) = (/'C1 ','Ci ','Cs ','C2 ','C2v','C2h','D2 ','D2h'/)

      iprint = max(iprlvl,ntest)

      ! open direct access file DICTNRY
      call file_init(ffdict,dictnry,ftyp_da_unf,irecln)
      call file_open(ffdict)

      ludict = ffdict%unit

      ! read first record: information about where to find which record
      read (ludict,rec=1) irecst,ioda,ifilen,is,ipk
c dbg
c      print *,'first record from DICTNRY. irecst,is,ipk:',irecst,is,ipk
c      print *,'          ii        ioda        nrec      ifilen'
c      print *,'------------------------------------------------'
c      do idx=1,len_da
c       if (ioda(idx).ge.0)
c     &     write(lulog,'(x,4i12)') idx, ioda(idx),
c     &                             ifilen(idx)/irecln+1, ifilen(idx)
c      end do
c dbgend

      ! read energy quantities
      read (ludict,rec=ioda(6)) potnuc,eelct,etot2,sz,s2,ecore,emcscf,
     &                          eerd,e1,e2,ven,vee,epot,ekin,
     &                          estate,statn
      ispin = nint(2d0*s2)+1
      nstate = nint(statn)

      ! read number of orbital parameters
      read (ludict,rec=ioda(5)) nfroz,nocct,n_act,norbs,norbt,num1
      ! unpack number of electrons and irrep
      lsym = mod(num1,1000)
      nactel = num1/1000 - 2*nocct !what if nfroz>0 ???

      ! read orbital energies and set up proposal for frozen core
      allocate(orb_en(norbt),orb_sym(norbt),orb_lab(norbt))
      read (ludict,rec=ioda(17)) orb_en(1:norbt)
      read (ludict,rec=ioda(262)) orb_sym(1:norbt)
      read (ludict,rec=ioda(324)) orb_lab(1:norbt)
c      ! now get nsym (lowest possible 2^n number):
c      mxirrep = maxval(orb_sym(1:norbt))
c      nsym = mxsym
c      do while (nsym/2.ge.mxirrep)
c        nsym = nsym/2
c      end do

      ! For a strange (?) reason, GAMESS may mess up the irrep numbers
      ! for the orbitals. So let's restore them by help of the labels.
      ! First try to recognize point group
      isgroup(1:8) = .true. ! stands for: C1,Ci,Cs,C2,C2v,C2h,D2,D2h
      do idx = 1, norbt
        select case(trim(orb_lab(idx)))
        case('A') ! not Ci,Cs,C2v,C2h,D2h
          isgroup(2:3) = .false.
          isgroup(5:6) = .false.
          isgroup(8) = .false.
        case('AG','AU') ! not C1,Cs,C2,C2v,D2
          isgroup(1) = .false.
          isgroup(3:5) = .false.
          isgroup(7) = .false.
        case('A''','A''''') ! only Cs
          isgroup(1:2) = .false.
          isgroup(4:8) = .false.
        case('B') ! only C2
          isgroup(1:3) = .false.
          isgroup(5:8) = .false.
        case('A1','A2') ! only C2v
          isgroup(1:4) = .false.
          isgroup(6:8) = .false.
        case('B1','B2') ! only C2v or D2
          isgroup(1:4) = .false.
          isgroup(6) = .false.
          isgroup(8) = .false.
        case('BU','BG') ! only C2h
          isgroup(1:5) = .false.
          isgroup(7:8) = .false.
        case('B3') ! only D2
          isgroup(1:6) = .false.
          isgroup(8) = .false.
        case('B1G','B2G','B3G','B1U','B2U','B3U') ! only D2h
          isgroup(1:7) = .false.
        case default
          call quit(1,'read_env_gamess',
     &              'unknown irrep label: '//trim(orb_lab(idx)))
        end select
      end do
      isym = 0
      do idx = 1, 8
        if (isgroup(idx)) then
          isym = isym + 1
          if (isym.eq.1) igroup = idx !try first possibility
        end if
      end do
      if (isym.ne.1.and.igroup.ne.1) call warn('read_env_gamess',
     &       'Could not unambiguously identify point group!')

      ! irrep numbers as in GAMESS manual (for $DET):
      irreps(1:8) = '   '
      select case(igroup)
      case(1)
        nsym = 1
        irreps = (/'A  ','   ','   ','   ','   ','   ','   ','   '/)
      case(2)
        nsym = 2
        irreps = (/'AG ','AU ','   ','   ','   ','   ','   ','   '/)
      case(3)
        nsym = 2
        irreps = (/"A' ","A''",'   ','   ','   ','   ','   ','   '/)
      case(4)
        nsym = 2
        irreps = (/'A  ','B  ','   ','   ','   ','   ','   ','   '/)
      case(5)
        nsym = 4
        irreps = (/'A1 ','A2 ','B1 ','B2 ','   ','   ','   ','   '/)
      case(6)
        nsym = 4
        irreps = (/'AG ','BU ','BG ','AU ','   ','   ','   ','   '/)
      case(7)
        nsym = 4
        irreps = (/'A  ','B1 ','B2 ','B3 ','   ','   ','   ','   '/)
      case(8)
        nsym = 8
        irreps = (/'AG ','B1G','B2G','B3G','AU ','B1U','B2U','B3U'/)
      case default
        call quit(1,'read_env_gamess','impossible.')
      end select

      do idx = 1, norbt
        do isym = 1, nsym
          if (trim(orb_lab(idx)).eq.trim(irreps(isym))) then
            orb_sym(idx) = isym
            exit
            if (isym.eq.nsym) call quit(1,'read_env_gamess',
     &               'There must be an error in this routine')
          end if
        end do
      end do
      deallocate(orb_lab)
c dbg
c      print *,'   orbital  symmetry    energy'
c      print *,'------------------------------'
c      do idx = 1, norbt
c        write(lulog,'(x,2i10,f10.6)') idx,orb_sym(idx),orb_en(idx)
c      end do
c dbgend

      ! though irrep indices may differ from other codes
      ! (e.g. for C2v irrep order is A1 A2 B1 B2)
      ! the multiplication table should be the same as in multd2h.h.

      nfro = 0
      nrhf = 0
      nash = 0
      norb = 0
      do idx = 1, norbt
        isym = orb_sym(idx)
        norb(isym) = norb(isym) + 1
        if (idx.le.nfroz) nfro(isym) = nfro(isym) + 1
        if (idx.le.nocct) nrhf(isym) = nrhf(isym) + 1
        if (idx.gt.nocct.and.idx.le.nocct+n_act)
     &             nash(isym) = nash(isym) + 1
      end do

      ! GAMESS sorts orbitals according to energy so it's easy
      ! to set up irrep array for orbitals.
      ! we set it up for all orbitals since we need this information
      ! in set_orbinf
      ! find bound orbitals:
      orb_info%n_bound_orbs = norbt
      do idx = 1, norbt
        if (orb_en(idx).ge.thr_auto_freeze) exit
        orb_info%n_freeze_rcmd = orb_info%n_freeze_rcmd+1
      end do

      ! just copy from orb_sym:
      allocate(orb_info%isym_bound_orbs(orb_info%n_bound_orbs))
      orb_info%isym_bound_orbs(1:orb_info%n_bound_orbs)
     &      = orb_sym(1:orb_info%n_bound_orbs)

      deallocate(orb_en,orb_sym)

      if (iprint.ge.50) then
        write(lulog,*) 'data from DICTNRY:'
        write(lulog,*) 'potnuc= ',potnuc
        write(lulog,*) 'eelct = ',eelct
        write(lulog,*) 'etot2 = ',etot2
        write(lulog,*) 'emcscf= ',emcscf
        write(lulog,*) 'ecore = ',ecore
        write(lulog,*) 'estate= ',estate(1:nstate)
        write(lulog,*) 'nstate= ',nstate
        write(lulog,*) 'mult  = ',ispin
        write(lulog,*) 'Ms    = ',sz
        write(lulog,*) 'nactel= ',nactel
        write(lulog,*) 'lsym  = ',lsym
        write(lulog,*) 'symm. = ',groups(igroup)
        write(lulog,*) 'nsym  = ',nsym
        write(lulog,*) 'nfroz = ',nfroz
        write(lulog,*) 'nocct = ',nocct
        write(lulog,*) 'n_act = ',n_act
        write(lulog,*) 'norbs = ',norbs
        write(lulog,*) 'norbt = ',norbt
        write(lulog,'(x,a,8i4)') 'nfro   = ',nfro(1:8)
        write(lulog,'(x,a,8i4)') 'nrhf   = ',nrhf(1:8)
        write(lulog,'(x,a,8i4)') 'nash   = ',nash(1:8)
        write(lulog,'(x,a,8i4)') 'norb   = ',norb(1:8)
        write(lulog,'(x,a)') 'sym_bound_orbs:'
        write(lulog,'(x,10i4)') orb_info%isym_bound_orbs
        write(lulog,'(x,a,i4)')  'n_freeze_rcmd: ',
     &       orb_info%n_freeze_rcmd
      end if

      call file_close_keep(ffdict)

      nspin = 1
      ngas = 2
      if (nfroz.gt.0) ngas = ngas+1
      orb_info%nactel = nactel
      orb_info%nactorb = n_act
      orb_info%lsym = lsym
      orb_info%imult = ispin
      orb_info%ims = nint(2*sz)
      if (n_act.gt.0) then
        ! test whether this can be treated as a simple
        ! high spin open shell case:
        if (.false..and.nactel.eq.n_act.and.ispin.eq.nactel+1) then
          ! we should check the symmetry here ...
          write(lulog,*) 'high-spin valence shell detected'
          ngas = ngas+1
          nspin = 2
        else
          write(lulog,*) 'valence shell is not high-spin ...'
c let pass to enable CAS calculations
          ngas = ngas+1
        end if
      end if

      orb_info%nspin = nspin
      orb_info%nsym = nsym
      orb_info%ngas = ngas
      orb_info%ntoob = norbt
      orb_info%nbast = norbt ! number of BF = number of orbs (correct?)
      orb_info%nxbast = 0
      orb_info%caborb = 0

      ! use the data to initialize orb_info structure
      allocate(orb_info%nbas(nsym),
     &     orb_info%ntoobs(nsym),orb_info%igassh(nsym,ngas),
     &     orb_info%iad_gas(ngas),orb_info%ihpvgas(ngas,nspin))
      allocate(orb_info%cab_orb(nsym),
     &              orb_info%nxbas(nsym) )

      orb_info%nbas(1:nsym) = norb(1:nsym) ! sym of BF = sym of orbs (?)
      orb_info%ntoobs(1:nsym) = norb(1:nsym)
      if (nfroz.gt.0) then
        ! not sure whether GAMESS' frozen orbitals are what we want
        call quit(1,'read_env_gamess',
     &       'check first what GAMESS means by freezing orbitals!')
        orb_info%iad_gas(1:ngas) = (/1,2,2/)
        orb_info%ihpvgas(1:ngas,1) = (/1,1,2/)
        orb_info%igassh(1:nsym,1) = nfro(1:nsym)
        orb_info%igassh(1:nsym,2) = nrhf(1:nsym)-nfro(1:nsym)
        orb_info%igassh(1:nsym,3) = norb(1:nsym)-nrhf(1:nsym)
      else
        if (nspin.eq.1.and.n_act.eq.0) then
          orb_info%iad_gas(1:ngas) = (/2,2/)
          orb_info%ihpvgas(1:ngas,1) = (/1,2/)
          orb_info%igassh(1:nsym,1) = nrhf(1:nsym)
          orb_info%igassh(1:nsym,2) = norb(1:nsym)-nrhf(1:nsym)
        else if (nspin.eq.1) then
          orb_info%iad_gas(1:ngas) = (/2,2,2/)
          orb_info%ihpvgas(1:ngas,1) = (/1,3,2/)
          orb_info%igassh(1:nsym,1) = nrhf(1:nsym)
          orb_info%igassh(1:nsym,2) = nash(1:nsym)
          orb_info%igassh(1:nsym,3)
     &                  = norb(1:nsym)-nrhf(1:nsym)-nash(1:nsym)
        else
          orb_info%iad_gas(1:ngas) = (/2,2/)
          orb_info%ihpvgas(1:ngas,1) = (/1,1,2/)
          orb_info%ihpvgas(1:ngas,2) = (/1,2,2/)
          orb_info%igassh(1:nsym,1) = nrhf(1:nsym)
          orb_info%igassh(1:nsym,2) = nash(1:nsym)
          orb_info%igassh(1:nsym,3) =
     &         norb(1:nsym)-nrhf(1:nsym)-nash(1:nsym)
        end if
      end if
      orb_info%cab_orb(1:nsym)=0
      orb_info%nxbas(1:nsym)=0

      return
      end


C NMR_READAMPPHASE: read nmr image (amp/phase) file into Anmap map-catalogue
C
C Document origin and update of this routine
C   P. Alexander, MRAO, Cambridge, 09/04/92
C
*-

C define work array
       integer       nm, nb
       integer       msize, bsize
       parameter    (msize = 256*256)
       parameter    (bsize=1024)
       parameter    (nm=4)
       parameter    (nb=1)
       real*4        map_array( nm*msize + nb*bsize )
       character     cline*(1024)
C error status
       integer       status

C perform standard initialization
       status = 0
       call io_enqline( cline, status )
       call io_setcli( cline )

       call stack_init(nm,msize,nb,bsize,status)
C call user routine
       call nmr_read_image( map_array, status )

C check status value and report an error to the user
       call cmd_err(status,'NMR-READ','Failed ')

C finally perform standard shut-down
       call anm_end( status )

       end
C
C
*+ nmr_read_image

       subroutine nmr_read_image(map_array,status)
C      -------------------------------------------
C
C Read an NMR image file into Anmap
C
C Updated:
C   map data
       real*4        map_array(*)
C Returned:
C   error status word
       integer       status
C
C An NMR image file consisting of one or more frames is read into
C the Map catalogue.  Each frame is placed in a separate catalogue entry.
C
*-

       include '/mrao/include/chrlib_functions.inc'
       include '/mrao/include/iolib_constants.inc'

C Local variables
C   file name and user name
       character   filename*(iolen_file), user_name*(iolen_user)
       character   dir*(iolen_file), type*(iolen_type), val*(5),
     *             source*(iolen_file), string*(iolen_file)
       character*1 next_byte
       integer     bsize
       parameter  (bsize = 128*128*32)
       real*4      buffer(bsize)
C   execution mode variables
       integer     mode, termno
       real*8      dxsize
C   mini redtape of map
       integer     minirt(8)
C   pointers to map data
       integer     ip_map, imap
C   size, centre pixel of output region and loop counters
       integer     nx, ny, nf, n, i, j, ls, m
       integer     iunit
C   function to read
       integer     next_int

C   redtape options
       real*8        pi4
       parameter    (pi4 = 3.14159265D+0/4.0)

C check status on entry
       if (status.ne.0) return
       iunit = 0

C prompt for file and open
       call io_getfil('NMR-image file-name : ',' ',filename,status)
       if (status.ne.0) goto 999

C find input style
       dxsize = 1.0D+0
*       call io_geti('X/U-dimension : ','128',nx,status)
*       ny = nx
*       call io_geti('Y/V-dimension : ','*',ny,status)
*       call io_geti('Number-of-frames : ','1',nf,status)

C open input data file
       call io_nxtlun(iunit,status)
       open (unit=iunit,file=filename(1:chr_lenb(filename)),
     + form = 'binary',
     + status = 'old',access = 'direct',recl = 1,
     + iostat = status )
       status = 0
C read header information
       i = 775
       nf = next_int( iunit, i )
       i = 784
       nx = next_int( iunit, i )
       ny = next_int( iunit, i )
       if (nf*nx*ny.gt.bsize) then
         print *,'*** (NMR-READ) Buffer size execeeded : failes'
         goto 999
       endif
C initialise the redtape for this map:
       call nwredt(nx,ny,3,0,status)
       call stmapj(3,dxsize,0.0D+0,1950.0D+0,0.0D+0,status)
       call stmapc(pi4,pi4,1950.0D+0,1950.0D+0,' ',status)
       call sttype(0.0,-1,'UNKNOWN','UNKNOWN',status)
       call adredt('CREATED','IN-MAP',status)
       call io_enqexe(user_name,mode,termno)
       call adredt('OWNER',user_name,status)
       call adredt('USER',user_name,status)
       call enminirt(minirt,status)

C set up output map
       dir = ' '
       string = ' '
       type = ' '
       call io_brkfil(filename,dir,string,type)
       source = string(1:chr_lenb(string))//'-'//type
       call io_getwrd('Source-name : ',source,source,ls,status)
       if (status.ne.0) goto 999

C read each image frame
       i = 13057
       m = 0
       do n=1,nf
         print *,'Reading frame ',n
         do j=1,2*nx*ny
           m = m + 1
           read(iunit,REC=i) next_byte
           buffer(m) = ichar(next_byte)
           i = i + 1
           read(iunit,REC=i) next_byte
           buffer(m) = buffer(m) + ichar(next_byte)*256
           i = i + 1
           read(iunit,REC=i) next_byte
           buffer(m) = buffer(m) + ichar(next_byte)*256*256
           i = i + 1
           if(buffer(m).gt.16777216/2)then
              buffer(m)=buffer(m)-16777216
            end if
         enddo
       enddo
       if (iunit.ne.0) close(iunit)

C place data into map catalogue
       call cmd_init( status )
       call mapcat_open(status)
       m = 0
       do n=1,nf
         string = ' '
         if (nf.gt.1) then
           call chr_chitoc(n,val,ls)
           string = source(1:chr_lenb(source))//'REAL-'//val(1:ls)
         else
           string = source(1:chr_lenb(source))//'-REAL'
         endif
         call redt_setsr(string(1:chr_lenb(string)),'IN-MAP',status)
         call map_alloc_out(nx,ny,'DIRECT',imap,ip_map,status)
         j = 0
         do i=1,2*nx*ny,2
           j = j + 1
           map_array(ip_map+j-1) = buffer(m+i)
         enddo
         call map_end_alloc(imap,map_array,status)
         if (nf.gt.1) then
           call chr_chitoc(n,val,ls)
           string = source(1:chr_lenb(source))//'-IMAG'//val(1:ls)
         else
           string = source(1:chr_lenb(source))//'-IMAG'
         endif
         call redt_setsr(string(1:chr_lenb(string)),'IN-MAP',status)
         call map_alloc_out(nx,ny,'DIRECT',imap,ip_map,status)
         j = 0
         do i=2,2*nx*ny,2
           j = j + 1
           map_array(ip_map+j-1) = buffer(m+i)
         enddo
         call map_end_alloc(imap,map_array,status)
         m = m + 2*nx*ny
       enddo
       call mapcat_close( status )

C check status value
999    call cmd_err(status,'NMR-READ','Failed ')
       end
C
C
       integer function next_int ( iunit, i )
C      --------------------------------------
C
       character*1 next_byte
       integer iunit, i, iv
       iv = 0
       read(iunit,REC=i) next_byte
       iv = ichar(next_byte)
       i = i + 1
       read(iunit,REC=i) next_byte
       iv = iv + ichar(next_byte)*256
       i = i + 1
       read(iunit,REC=i) next_byte
       iv = iv + ichar(next_byte)*256*256
       i = i + 1
       next_int = iv
       end
       character*1 function next_char ( iunit, i )
C      -------------------------------------------
C
       character*1 next_byte
       integer iunit, i
       read(iunit,REC=i) next_byte
       next_char = next_byte
       i = i + 1
       end


c     ****************************************************************
c     *                                                              *
c     *                      subroutine lfinda                       *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 11/27/09 rhd               *
c     *                                   added thread parallel
c     *                                                              *
c     *     this subroutine computes the step length for the         *
c     *     current iteration of the linear pcg algorithm.           *
c     *                                                              *
c     *     this version calls the unrolled versions of lmprd, the   *
c     *     matrix-vector multiplication routine.  There is an       *
c     *     unrolled version for each element in warp3d.             *
c     *                                                              *
c     ****************************************************************
c
c
c
      subroutine lfinda( step, stpitr, iter, trcpcg, z1tr1, alpha,
     &                   sdir )
c
      use elem_block_data, only: estiff_blocks, edest_blocks
c
      implicit integer (a-z)
$add common.main
#dbl      double precision
#sgl      real
     &  z1tr1, alpha, ptap, zero, sdir(*)
c
#dbl      double precision,
#sgl      real,
     & dimension(:,:), pointer :: estiff_block
       integer, dimension(:,:), pointer :: edest_block
#dbl      double precision,
#sgl      real,
     & dimension(:,:), allocatable :: ifv_threads
c
      logical trcpcg, valid_type
      data zero /0.0/
c
c                       perform linear matrix product. the lm
c                       product is stored in the internal force
c                       vector, as the ifv will not be used again
c                       before its next update.
c
c                       initialize the product vector.
c
c
      ifv(1:nodof) = zero
      allocate( ifv_threads(nodof,num_threads) )
      call zero_vector( ifv_threads, num_threads*nodof )
c
c
c                       perform the mutliplication in element blocks.
c
c                       to provide faster execution, fully unrolled
c                       versions of lmprd for each element type are provided.
c
c
      call omp_set_dynamic( .false. )
c$OMP PARALLEL DO PRIVATE( blk, now_thread, span, felem, type,
c$OMP&                     totdof, estiff_block, edest_block,
c$OMP&                     valid_type )
c$OMP&         SHARED( nelblk, elblks, iprops, estiff_blocks,
c$OMP&                 edest_blocks, sdir, ifv_threads )
      do blk = 1, nelblk
         now_thread = omp_get_thread_num() + 1
         span   = elblks(0,blk)
         felem  = elblks(1,blk)
         type   = iprops(1,felem)
         totdof = iprops(2,felem) * iprops(4,felem)
         utsz   = (totdof * ( totdof + 1 )) / 2
         estiff_block => estiff_blocks(blk)%ptr
         edest_block  => edest_blocks(blk)%ptr
         valid_type = ( type .ge. 1 .and. type .le. 5 )
     &                .or. type .eq. 12
         if ( .not. valid_type ) then
             write(*,9000) type, felem
             call die_abort
         end if
c
         felem = 1
c
         if ( type . eq. 2 .or. type .eq. 12 )  then
            call lmprd_8node( sdir, ifv_threads(1,now_thread),
     &           estiff_block(1,1), span, edest_block(1,1) )
         else
            call lmprd_gen( sdir, ifv_threads(1,now_thread),
     &           estiff_block(1,1), span, totdof, utsz,
     &           edest_block(1,1) )
         endif
      end do
c$OMP END PARALLEL DO
c
c                       reduction of thread ifv vectors into
c                       unique system vector.
c
      do j = 1, num_threads
       ifv(1:nodof) = ifv(1:nodof) +
     &                       ifv_threads(1:nodof,j)
      end do
      deallocate( ifv_threads )
c
c                       compute the triple product sdir transpose * lm *
c                       sdir.
c
      ptap = zero
      do i = 1, nodof
         ptap = ptap + sdir(i)*ifv(i)
      end do
c
c                      compute the step length.
c
      alpha = z1tr1 / ptap
c
c                       output the value of alpha if the trace flag
c                       is on.
c
      if( trcpcg ) then
         call oualph( step, stpitr, iter, alpha )
      end if
c
      return
c
 9000 format('>>> FATAL SYSTEM ERROR: warp3d does not have the',
     &     /,'                        code implemented to process',
     &     /,'                        an element type. routine lfinda',
     &     /,'                        element type, element no.:',
     &     2i8,
     &     /,'                        job terminated...')
c
      end