!!**.****|****.****|****.****|****.****|****.****|****.****|****.****|****.****|
!! * YIELDX_011000_imos.f *                        galprop package * 4/14/2000
!!**"****!****"****!****"****!****"****!****"****!****"****!****"****!****"****|

c### the code was changed to make it compatible with NAG f95 compiler (Linux).
c### Changes are marked by "imos"; I.Moskalenko 2/15/2000
c###
      SUBROUTINE YIELDX(IZ, IA, JZ, JA, EJ, QJ)                 ! Dec 1999
C*****************************************************************************
C       IZ IA :  charge and mass of the nucleus
C       JZ JA :  charge and mass of spallation product (He-6 and heavier)
C       EJ    :  energy in MeV/n
C       QJ    :  cross section in mb
C
C       The code was developed at NRL by Rein Silberberg and C. H. Tsao.
C       It is designed for quick estimation of cross sections only.
C       The results are not suited for physical interpretation.
C
C       This latest version is undertaken with NASA's sponsorship
C       and the assistance of Dr. A.F. Barghouty at the Roanoke College
C
C         E-mail:  tsao@crs2.nrl.navy.mil
C
C       The code is available at:  http//spdsch.phys.lsu.edu
C*****************************************************************************
      COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,ANZJ,AA,AE,AC,EC
      QJ = 0
      IF (IZ*IA .EQ. JZ*JA)  RETURN
      A = IA
      Z = IZ
      IJ = IZ - JZ
      NN = (IA - IZ) - (JA - JZ)
      X = NN
      IF (IA.LT.JA .OR.  IZ.GT.92 .OR.  IZ.LE. 2)  RETURN
      IF (IJ.LT.-1 .OR.  NN.LT. 0 .OR.  JZ.LE. 1)  RETURN
      IF (IJ.EQ.-1 .AND. IA.GE.JA)  THEN
        CALL PXN(Z, A, X, EJ, QJ)
        RETURN
      ENDIF
      IF (IZ-JZ.GT.IA-JA .OR. IZ*IA.EQ.JZ*JA)  RETURN
      IF (JZ.LE. 4)   CALL YIELD1(IZ, IA, JZ, JA, EJ, QJ)
      IF (IZ.EQ. 6 .AND. EJ.GT.200. .AND. EJ.LE.400.)
     1QJ = QJ*(1.-0.002*(EJ-200. ))
      IF (IZ.EQ. 6 .AND. EJ.GT.400. .AND. EJ.LE.1000.)
     1QJ = QJ*0.6
      IF (IZ.EQ. 6 .AND. EJ.GT.1000..AND. EJ.LE.5000.)
     1QJ = QJ*(.6+.0001*(EJ-1000.))
      IF (JZ.GE. 5 .AND. IZ.GE. 5 .AND. IZ.LE.16)
     2CALL YIELD2 (IZ, IA, JZ, JA, EJ, QJ)
      IF (JZ.GE. 5 .AND. IZ.GE.17 .AND. IZ.LE.20)
     3CALL YIELD3 (IZ, IA, JZ, JA, EJ, QJ)
      IF (JZ.GE. 5 .AND. IZ.GE.21 .AND. IZ.LE.92)
     4CALL YIELD4 (IZ, IA, JZ, JA, EJ, QJ)
      IF (IZ.EQ.6.AND.IA.EQ.12.AND.JZ.EQ.4.AND.JA.EQ. 8)  QJ = QJ*1.8
      IF (IZ.EQ.7.AND.IA.EQ.14.AND.JZ.EQ.6.AND.JA.EQ.12)  QJ = QJ*1.8
      IF (IZ.EQ.7.AND.IA.EQ.14.AND.JZ.EQ.6.AND.JA.EQ.13)  QJ = QJ*0.5
      IF (IZ.EQ.8.AND.IA.EQ.16.AND.JZ.EQ.6.AND.JA.EQ.12)  QJ = QJ*1.8
      IF (IZ.EQ.8.AND.IA.EQ.16.AND.JZ.EQ.7.AND.JA.EQ.14)  QJ = QJ*1.8
      IF (IZ.EQ.8.AND.IA.EQ.16.AND.JZ.EQ.7.AND.JA.EQ.15)  QJ = QJ*1.5
        IF (IZ.EQ. 8 .OR.IZ.EQ.10) THEN
          IF (IZ*2.EQ.IA.AND.JA-2*JZ.GE.2.AND.JZ.GE.5)    QJ=QJ*0.7
        ENDIF
        IF (IZ.GE. 9.AND.IZ.LE.16.AND.2*JZ-JA.EQ.1.AND.JZ.GE.9)QJ=QJ*.7
        IF (IZ.GE. 6.AND.IZ.LE.11.AND.2*JZ-JA.EQ.2.AND.JZ.GE.9)QJ=QJ*.4
        IF (IZ.GE.10.AND.IZ.LE.13)  THEN
          IF ((JZ.EQ.6.OR.JZ.EQ.8).AND.JZ*2.EQ.JA)  QJ=QJ*2.
        ENDIF
        IF((IZ.EQ.10.AND.IA.EQ.20).or.(IZ.EQ.12.AND.IA.EQ.24)) THEN
          IF (JZ.EQ.7.AND.(JA.EQ.14.OR.JA.EQ.15))            QJ=QJ*1.5
        ENDIF
        IF (IZ.GE.10.AND.IZ.LE.16.AND.JZ.EQ.9 )              QJ=QJ*0.8
C
        IF ((IZ.EQ.12.OR.IZ.EQ.14).AND.(2*IZ.EQ.IA)) THEN
          IF (IZ-JZ.EQ.2.AND.IA-JA.EQ.4)                     QJ=QJ*1.6
          IF (IZ-JZ.EQ.1.AND.IA-JA.EQ.1)                     QJ=QJ*1.6
        ENDIF
C
        IF ((IZ.EQ.16).AND.(IA.EQ.32)) THEN
          IF (IZ-JZ.EQ.2.AND.IA-JA.EQ.4)                     QJ=QJ*1.6
          IF (IZ-JZ.EQ.1.AND.IA-JA.EQ.1)                     QJ=QJ*1.2
          IF (IZ-JZ.EQ.1.AND.IA-JA.EQ.2)                     QJ=QJ*0.8
          IF (IZ-JZ.EQ.3.AND.IA-JA.EQ.5)                     QJ=QJ*1.4
          IF (IZ-JZ.EQ.4.AND.IA-JA.EQ.8)                     QJ=QJ*1.4
          IF (IZ-JZ.EQ.8.AND.IA-JA.EQ.16)                    QJ=QJ*1.4
        ENDIF
        IF ((IZ.EQ.18.OR.IZ.EQ.20).AND.2*IZ.EQ.IA)  THEN
          IF (IZ-JZ.EQ.1.OR.IZ-JZ.EQ.3)                      QJ=QJ*0.7
        ENDIF
        IF (IZ.EQ.20.AND.IA.EQ.40.AND.(JZ.EQ.12.OR.JZ.EQ.14))QJ=QJ*2.4
        IF (IZ.EQ.20.AND.IA.EQ.40.AND.(JZ.EQ.18.OR.JZ.EQ.16))QJ=QJ*1.4
        IF (IZ.GE.24.AND.IZ.LE.28) THEN
          if (JZ.GE.20.AND.JZ.LE.23.and.JA-JZ*2.GE.6)        QJ=QJ*0.5
        ENDIF
        IF((IZ.EQ.26.AND.IA.EQ.56).OR.(IZ.EQ.24.AND.IA.EQ.52)) THEN
          IF((JZ.EQ.20).OR.(JZ.EQ.18).OR.(JZ.EQ.16))         QJ=QJ*1.3
        ENDIF
        IF (IZ.EQ.28.AND.IA.EQ.58.AND.(JZ.ge.19.and.JZ.le.22))QJ=QJ*1.4
        F2A= 1.+.9*EXP(-((EJ-1230)/150)**2)*EXP(-(ABS(IZ-JZ-12)/5.)**2)
        F2B= 1.+.9*EXP(-((EJ-1230)/950)**2)*EXP(-(ABS(IZ-JZ-12)/5.)**2)
        IF (IZ.GE.30.AND.IZ-JZ.GE.6.AND.EJ.LT.1230.)  QJ = QJ*F2A
        IF (IZ.GE.30.AND.IZ-JZ.GE.6.AND.EJ.GE.1230.)  QJ = QJ*F2B
C
        IF (IZ.EQ. 6.AND.JZ.GE. 3.AND.JZ.LE. 4) QJ=QJ*1.4
C
      IF (IZ.EQ.26.AND.IA.EQ.56) THEN
          IF (JZ.EQ.23)          QJ=QJ*(1. - 0.6*EXP(-((52-JA)/2.6)**2))
          IF (JZ.EQ.24.AND.JA.EQ.54) QJ=0.7*QJ
          IF (JZ.EQ.25.AND.JA.GE.54.AND.JA.LE.55)
     1                           QJ=QJ*(1.7 - (JA-54)*0.45)
          IF (JZ.EQ.17)          QJ = QJ*0.9
        ENDIF
        IF (IZ.EQ.21.AND.JZ.GE.6)  THEN
            CALL YIELD3(IZ,IA,JZ,JA,EJ,Q3)
            QJ = SQRT(QJ*Q3)
        ENDIF
        IF (IZ.EQ.20.AND.JZ.GE.6)  THEN
            CALL YIELD4(IZ,IA,JZ,JA,EJ,Q4)
            QJ = SQRT(QJ*Q4)
        ENDIF
        IF (JZ .EQ. 5)  THEN
          CALL YIELD1(IZ, IA, JZ, JA, EJ, Q1)
          QJ = SQRT(Q1*QJ)
          IF (IZ.EQ.7.AND.IA.EQ.14.AND.JZ.EQ.5.AND.JA.EQ.10) QJ=QJ*1.8
          IF (IZ.EQ.6.AND.IA.EQ.12.AND.JZ.EQ.5.AND.JA.EQ.10) QJ=QJ*1.3
          IF (IZ.EQ.6.AND.IA.EQ.12.AND.JZ.EQ.5.AND.JA.EQ.11) QJ=QJ*1.3
          RETURN
        ENDIF
C
C       The followings were added just prior to 26th ICRC date
C
        IF (IZ.EQ.20.AND.IA.EQ.40.AND.JZ.EQ.16.AND.JA.EQ.31) QJ=QJ*0.7
        IF (IZ.EQ.20.AND.IA.EQ.40.AND.JZ.EQ.15.AND.JA.EQ.31) QJ=QJ*1.3
        IF (IZ.EQ.18.AND.IA.EQ.40.AND.JZ.EQ.16.AND.JA.EQ.31) QJ=QJ*1.2
        IF (IZ.EQ.18.AND.IA.EQ.40.AND.JZ.EQ.15.AND.JA.EQ.31) QJ=QJ*1.2
        IF (IZ.EQ.14.AND.IA.EQ.28.AND.JZ.EQ.12.AND.JA.EQ.26) QJ=QJ*1.3
        IF (IZ.EQ.12.AND.IA.EQ.24.AND.JZ.EQ.12.AND.JA.EQ.23) QJ=QJ*1.4
        IF (IZ.EQ.10.AND.IA.EQ.20.AND.JZ.EQ.10.AND.JA.EQ.19) QJ=QJ*1.3
        IF (IZ.EQ.10.AND.IA.EQ.20.AND.JZ.EQ. 9.AND.JA.EQ.19) QJ=QJ*1.2
        IF (IZ.EQ. 8.AND.IA.EQ.16.AND.JZ.EQ. 7.AND.JA.EQ.14) QJ=QJ*0.8
        IF (IZ.EQ. 8.AND.IA.EQ.16.AND.JZ.EQ. 6.AND.JA.EQ.14) QJ=QJ*1.2
        IF (IZ.EQ. 6.AND.IA.EQ.12.AND.JZ.EQ. 4.AND.JA.EQ.10) QJ=QJ*1.5
          RETURN
        END
      SUBROUTINE YIELD1 (IZ, IA, JZ, JA, EJ, QJ)
C     IZ .GE. 3  AND JZ = 2 TO 4
      COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,PJ,PN,GA,ANZJ,AA,AE,AC,EC
      COMMON /QG/ QI,G1,G2,G3,G4
      COMMON /ST/ ST,SS,T
      DIMENSION  BA(92), CJ(56,26), C2(56), C3(56), C4(56), C5(56)
      DATA   BA / 16 * 0 ., 36., 38., 40., 44.
     1,           45., 48., 50., 52., 55.,55.7,58.5, 61., 64., 67.
     1,           70., 73., 75., 78., 80., 82., 84., 86., 89., 92.
     1,           93., 96., 98.,100.,103.,106.,108.,111.,114.,118.
     1,          122.,125.,127.,130.,133.,134.,137.,139.,141.,146.
     1,          146.,149.,153.,156.,159.,161.,165.,166.,169.,172.
     1,          175.,178.,181.,183.,186.,188.,192.,194.,197.,200.
     1,          204.,206.,209.,  0.,0.,0.,0. ,226.,227.,232.,231.,238./
      EQUIVALENCE(CJ(1, 2),C2),(CJ(1, 3),C3),(CJ(1, 4),C4),(CJ(1, 5),C5)
      DATA  C2/ 5*1.0,0.60,1.00,1.00,1.00,1.00,46*1. /
      DATA  C3/ 5*1.0,1.00,1.80,0.70,3.00,1.00,46*1. /
      DATA  C4/ 6*1.0,0.95,1.00,0.65,1.30,1.00,45*1. /
      DATA  C5/ 7*1.0,0.20,1.00,0.70,1.70,1.00,44*1. /
      DATA  QC/ 13.0/, QL / 13.0/ , B / 1.15/
      DATA  PC/  0. /, PL / 0.16/
      DATA  RC/ 1.80/, RL / 10.7/ , RU/ 0.25/
      DATA  S / 0.54/, C  / 0.32/
      T  = .003
      QR = 0.
      QE = 0.
      QF = 0.
      QH = 0.
      AE = 0.
      AC = 0.
      FE = 1.
      FF = 1.
      FA = 1.
      FZ = 1.
      PN = 1.
      GA = 1.
      AI = IA
      ZI = IZ
      AJ = JA
      ZJ = JZ
      AA = AI - AJ
      AM = BA(IZ)
      IF (AM .EQ. 0)    AM = IA
      AN = AJ - ZJ
      ANZJ = AN/ZJ
      PJ = CJ(JA,JZ)
      CN = .3*(AI-AM)/ZI
      KN = (IA - IZ) - (JA - JZ)
      JP = IZ - JZ + 1
      JN = JA - JZ
!### imos      MN = JN .AND. 1 ! JN,JZ = odd, TRUE =1 ### imos 1/21/2000
!### imos      MZ = JZ .AND. 1 ! JN,JZ = even,FALSE=0 ### imos 1/21/2000
      MN = 1                          ! ### imos 1/21/2000
      if (JN/2*2 .eq. JN) MN = 0      ! ### imos 1/21/2000
      MZ = 1                          ! ### imos 1/21/2000
      if (JZ/2*2 .eq. JZ) MZ = 0      ! ### imos 1/21/2000
!
      PN = 1.15
      IF (MZ .EQ. 1.AND.MN.LE.1)   PN = 0.9 - 0.1*MN
      EC = 68.7*AI**.866
      IF (EC.LT.1250.)  EC = 1250.
      EI = EJ
      IF (EI.GT.EC)   EI = EC
      H3 = 1.
      IF (EI.LT.80.)  H3 = 1. - EXP(-(EI/25.)**4)
      IF((JP.GT. 2).OR. (KN.GT. 1))     GO TO  3
      CX = 1.
      CT = 1.
      IF (JZ.EQ.4 .AND. JA.EQ.9)   CX = CJ(JA,JZ)/PN
      IF (AI/ZI.GT.2.)  CT = (ZI-2.)/((AI-ZI)-2.)
      IF (ZI.GT.5 .OR. CT.GT.1. .OR. AI-ZI.LE.2.)   CT = 1.
 1    IF (JP.GT. 1)      GO TO  2
      IF (KN.GT. 1)                     GO TO  3
      IF (AI .LE. 40.)   QN = 24.*(1. + .01*AI)
      IF (AI .GT. 40.)   QN = 1.02*(AI - 7.)
      IF (AI .GE. 63.)   QN = 57.
      IF (EI.LT.2500.)
     1FE = (1.0 + 2.1*EXP(-(EI/100.)**2) + 0.4*EXP(-EI/350.))*H3
      QH = QN * CX
      QJ = QH
      IF (EI.LT.EC)      QJ = QH*FE
      RETURN
 2    IF (KN.NE. 0)                     GO TO  3
      IF (EJ.LT.2500.)
     1FE = (1.0 - EXP(-(EJ/230.)**2) + 2.2*EXP(-EJ/75.)
     1   + .33*EXP(-((EJ-900.)/500.)**2))*H3
      QH = 21.*CX*CT
      QJ = QH*FE
      RETURN
 3    IF (IZ.LT.29)      GO TO  5
      IF (JZ.NE. 4)      FE = (EI/EC)**(.4*ZJ)
      IF (JZ.EQ. 4)      FE = (EI/EC)**1.8
      FA = EXP(.01*(AI - 56.)*((AN/ZJ - CN) - .45))
      IF (FA.LE.1.)      FA = 1.
      EI = EC
      ZI = 29.
      AI = 63.
 5    AT = IA
      IF (IA.GE.104)  AT = 104
      IF (IA.GE.64)   GO TO 7
      IF (IA.GT.34)   GO TO 6
      IF (IA.GE.14.AND.JA.EQ. 6.AND.JZ.EQ. 2)  FZ = 1. + .1*(IA-14)
      GO TO 8
 6    IF (JA.EQ. 6.AND.JZ.EQ. 2)  FZ = 3.0*(1. + .02*(IA-34))
      IF (JA.EQ. 6.AND.JZ.EQ. 3)  FZ = 1.0 + .02*(IA-34)
      IF (JA.EQ. 7.AND.JZ.LE. 4)  FZ = 1.0 + .01*(IA-34)
      GO TO 8
 7    IF (JA.EQ. 6.AND.JZ.EQ. 2)  FZ = 4.8 + 0.045*(AT-64.)
      IF (JA.EQ. 6.AND.JZ.EQ. 3)  FZ = 1.6 + 0.015*(AT-64.)
      IF (JA.EQ. 7.AND.JZ.EQ. 3)  FZ = 1.3 + 0.015*(AT-64.)
      IF (JA.EQ. 7.AND.JZ.EQ. 4)  FZ = 1.3 + .0105*(AT-64.)
      IF (JA.EQ. 8.AND.JZ.EQ. 3)  FZ = 1.0 + .0225*(AT-64.)
      IF (JA.EQ. 9.AND.JZ.EQ. 3)  FZ = 1.0 + .0125*(AT-64.)
      IF (JA.EQ. 9.AND.JZ.EQ. 4)  FZ = 1.0 + .01  *(AT-64.)
      IF (JA.GE.10.AND.JZ.LE. 5)  FZ = 1.0 + .0050*(AT-64.)
8     DA = AI - AJ
      AA = DA
      AE = 31.5 + .052*(AI - 36.0)*(ALOG(EI) - 3.17)
      IF (AA.GT.AE)      DA = AE
      Q1 = QC
      IF (EI .LT. 1250.)  Q1 = QL*EXP(B*(1. - .0008*EI))
      PE = PC
      IF (EI .LT. 1250.) PE = PL*(1. - .0008*EI)
      RE = RC
      IF (EI .LT. 1250.) RE = RL/EI**RU
      IF((IZ.GT.20).AND.(EI.LT.1250.))   RE = 1.8
      IF((EI.LT.1250.).AND.(IZ.GE.21)) Q1=Q1*2*EXP(-((EI-650)/720)**2)
      IF (AI/ZI .GE. 2.)   SS = S - C*(AI/ZI - 2.)**1.4
      IF (AI/ZI .LT. 2.)   SS = S + C*(2. - AI/ZI)**1.4
      ST = (ZJ - (SS - T*AJ)*AJ)
      ZA = (ZJ - (SS - T*AJ)*AJ)**2
      QR = Q1*EXP(-PE*DA - RE*ZA)*FA*FZ*CJ(JA,JZ)
      QH = QC*EXP(-RC*ZA)*FA*FZ*CJ(JA,JZ)
      QE = QH*FE
      IF (IZ.LT.29)      QJ = QR
      IF (IZ .GE. 29)   QJ = QE
      IF (JP.EQ.3 .AND. KN.EQ.0)   QJ = 1.5*QR
C
C     FOLLOWING REVISIONS ARE ADDED 12/27/78
      IF (IZ .LE. 20)   RETURN
      QI = QJ
      EX = 68.7*56.**.866*EJ/EC
      AC = 31.5 + .045*(AI-36.)*(ALOG(AI)+1.23)
      G1 = 1.-0.6*(1.-EXP(-(EJ/1000.)**2))*EXP(-(EJ/2000.)**2)
     1       +0.2*(1.-EXP(-(EJ/3000.)**2))
      GX = 1.-0.6*(1.-EXP(-(EX/1000.)**2))*EXP(-(EX/2000.)**2)
     1       +0.2*(1.-EXP(-(EX/3000.)**2))
      G2 = 1.-0.4*(1.-EXP(-(EX/2000.)**2))*EXP(-((EX-1800.)/1800.)**2)
     1       +.17*(1.-EXP(-(EX/2000.)**2))
      IF (EJ.GT.2500.)   G1=GX
      IF (EJ.GT.EC .AND. EJ.LT.2500.)   G1=SQRT(G1*GX)
      IF (IZ.GE.21 .AND. IZ.LE.28)   QJ = QR*G1
      IF (IZ.GT.28 .AND. AA.GT.AC)   QJ = QE*G2
C
      END
      SUBROUTINE YIELD2 (IZ, IA, JZ, JA, EJ, QJ)
C     5 .LE. IZ .LE. 16  AND  5 .LE. JZ .LE. IZ
      COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,PJ,PN,GA,ANZJ,AA,AE,AC,EC
      COMMON /ST/ ST,SS,T
      DIMENSION  CJ(56,26)
      DIMENSION  C5(56), C6(56), C7(56), C8(56), C9(56), CD(56)
      DIMENSION  D1(56), D2(56), D3(56), D4(56), D5(56), D6(56)
      EQUIVALENCE(CJ(1, 5),C5),(CJ(1, 6),C6),(CJ(1, 7),C7),(CJ(1, 8),C8)
      EQUIVALENCE(CJ(1, 9),C9),(CJ(1,10),CD),(CJ(1,11),D1),(CJ(1,12),D2)
      EQUIVALENCE(CJ(1,13),D3),(CJ(1,14),D4),(CJ(1,15),D5),(CJ(1,16),D6)
      DATA  C5/ 7*1.0,0.20,1.00,0.70,1.70,1.00,44*1.0/
      DATA  C6/ 9*1.0,0.60,46*1.0/
      DATA  C7/12*1.0,0.39,1.00,2.00,41*1.0/
      DATA  C8/14*1.0,1.20,1.00,1.00,39*1.0/, C9/17*1.0,1.00,38*1.0/
      DATA  CD/18*1.0,0.60,1.00,0.83,35*1.0/, D1/21*1.0,1.20,34*1.0/
      DATA  D2,D3,D4,D5,D6/56*1.0,56*1.0,56*1.0,56*1.0,56*1.0/
      DATA  PC,PL,PU/.075,2.60,0.50/, S,C/.502,.26/
      DATA  RC,RL,RU/1.60,10.2,0.26/
      T  = .0005
      QR = 0.
      QE = 0.
      QF = 0.
      QH = 0.
      AE = 0.
      AC = 0.
      FE = 1.
      FF = 1.
      FA = 1.
      FZ = 1.
      GA = 1.
      AI = IA
      ZI = IZ
      AJ = JA
      ZJ = JZ
      AA = AI - AJ
      AN = AJ - ZJ
      ANZJ = AN/ZJ
      PJ = CJ(JA,JZ)
      PN = 1.15
      JN = JA - JZ
!### imos      MN = JN .AND. 1 ! JN,JZ = odd, TRUE =1 ### imos 1/21/2000
!### imos      MZ = JZ .AND. 1 ! JN,JZ = even,FALSE=0 ### imos 1/21/2000
      MN = 1                          ! ### imos 1/21/2000
      if (JN/2*2 .eq. JN) MN = 0      ! ### imos 1/21/2000
      MZ = 1                          ! ### imos 1/21/2000
      if (JZ/2*2 .eq. JZ) MZ = 0      ! ### imos 1/21/2000
!
      CX = 1.
      IF((MZ.EQ. 1).AND.(MN.LE. 1))   PN = 0.9 - 0.1*MN
      EC = 68.7*AI**.866
      IF (EC.LT.1250.)  EC = 1250.
      EI = EJ
      IF (EI.GT.EC)  EI = EC
      H3 = 1.
      IF (EI.LT.80.)  H3 = 1. - EXP(-(EI/25.)**4)
      KN = (IA - IZ) - (JA - JZ)
      JP = IZ - JZ + 1
      IF((JZ.EQ.7.AND.JA.EQ.13).OR.(JZ.EQ.10.AND.JA.EQ.19)) CX=CJ(JA,JZ)
      CT = (ZI - 2.)/((AI - ZI) - 2.)
      IF (ZI.GT.5. OR. CT.GT.1.)   CT = 1.
      IF (JP.GT. 1)      GO TO  2
 1    IF (KN.NE. 1)      GO TO  3
      IF (EI.LT.2500.)
     1FE =(1.0 + 2.1*EXP(-(EI/100.)**2) + 0.4*EXP(-EI/350.))*H3
      QH = 24.*(1.+ .01*AI)*CX
      QJ = QH
      IF (EI.LT.EC)      QJ = QH*FE
      GO TO 10
 2    IF((JP.GT. 2).OR. (KN.NE. 0))     GO TO  3
      IF (EJ.LT.2500.)
     1FE =(1.0 - EXP (-(EJ/230.)**2) + 2.2*EXP(-EJ/75.)
     1    + .33*EXP(-((EJ-900.)/500.)**2))*H3
      QH = 21.*CX*CT
      QJ = QH*FE
      GO TO 10
 3    F1 = 1. - .3*ALOG(AI/20.)
      PE = PC
      IF (EC .GT. 1250.)  PE = 0.77/AI**(2./3.)
      IF (EI.LT.EC)  PE = PL/EI**PU
      RE = RC
      IF (EI .LT. 1250.)  RE = RL/EI**RU
      IF (AI/ZI .GE. 2.)   SS = S - C*(AI/ZI - 2.)**1.4
      IF (AI/ZI .LT. 2.)   SS = S + C*(2. - AI/ZI)**1.4
      ST = (ZJ - (SS - T*AJ)*AJ)
      ZA = (ZJ - (SS - T*AJ)*AJ)**2
      Q1 = 27.6*(AI**(2./3.)-1.)*F1*PE*RE**.5/(1. - EXP (-PE*AI))
      QC = 27.6*(AI**(2./3.)-1.)*F1*PC*RC**.5/(1. - EXP (-PC*AI))
      QR = Q1*EXP(-PE*(AI - AJ))*EXP(-RE*ZA)*CJ(JA,JZ)*PN
      QJ = QR
      QH = QC*EXP (-PC*(AI - AJ))*EXP (-RC*ZA)*CJ(JA,JZ)*PN
      IF((JP.LT. 3).OR. (KN.NE. 0))     GO TO 10
      QJ = QR*AMIN1(.0022*AJ*AJ,1.)
      IF (JP.NE. 4)      GO TO 10
      IF (QJ.GT..5)      QJ = .5
 10   IF (IZ.GE.14 .AND. EI.GE.500.)    QJ=QJ*(1.+.12*(IZ-13))
      IF (IZ.GE.14 .AND. EI.GE.200. .AND. EI.LT.500.)
     &    QJ = QJ*(1.+.12*(IZ-13)*EXP(-((EI-500)/350)**2))
      IF (JP.EQ. 2 .AND. KN.EQ. 1 .AND. IZ.GE.12)  QJ = QJ*1.7
!### imos      IF (AJ/ZJ .GT. 1.8 .OR. IZ.GT.10) RETURN
      IF (AJ/ZJ-1.e-7 .GT. 1.8 .OR. IZ.GT.10) RETURN     ! ### imos 1/21/2000
      IF (JP.NE. 1 .OR.  KN.NE. 2)   QJ = QJ*0.3
      IF (JP.EQ. 1 .AND. KN.EQ. 2)   QJ = QJ*0.5
      END
      SUBROUTINE YIELD3(IZ, IA, JZ, JA, EJ, QJ)
C     IZ = 17 - 20  AND  JZ = 5 TO IZ
      COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,ANZJ,AA,AE,AC,EC
      COMMON /ST/ ST,S,T
      DIMENSION   BA(92)
      DATA   BA / 16 * 0 ., 36., 38., 40., 44.
     1,           45., 48., 50., 52., 55.,55.7,58.5, 61., 64., 67.
     1,           70., 73., 75., 78., 80., 82., 84., 86., 89., 92.
     1,           93., 96., 98.,100.,103.,106.,108.,111.,114.,118.
     1,          122.,125.,127.,130.,133.,134.,137.,139.,141.,146.
     1,          146.,149.,153.,156.,159.,161.,165.,166.,169.,172.
     1,          175.,178.,181.,183.,186.,188.,192.,194.,197.,200.
     1,          204.,206.,209.,  0.,0.,0.,0. ,226.,227.,232.,231.,238./
        AI = IA
        ZI = IZ
        AJ = JA
        ZJ = JZ
        AM = BA(IZ)
        IF (AM .EQ. 0.)  AM = IA
        EC = 68.7*AI**.866
        IF (EC.LT.1250.)   EC = 1250.
        EI = EJ
        IF (EI.GT.  EC )   EI = EC
        QR = 0.
        QE = 0.
        QF = 0.
        QH = 0.
        AE = 0.
        AC = 0.
        DX=0
        FE = 1.
        FF = 1.
        FA = 1.
        FZ = 1.
        GA = 1.
        CJ = 1.
        AA = AI - AJ
        H3 = 1. - EXP(-(AMIN1(EI,80.)/25.)**4)
        H4 = AMIN1(AMAX1((400./EI-2.2),1.),2.)
        AN = AJ - ZJ
        ANZJ = AN/ZJ
        JN = JA - JZ
!### imos      MN = JN .AND. 1 ! JN,JZ = odd, TRUE =1 ### imos 1/21/2000
!### imos      MZ = JZ .AND. 1 ! JN,JZ = even,FALSE=0 ### imos 1/21/2000
      MN = 1                          ! ### imos 1/21/2000
      if (JN/2*2 .eq. JN) MN = 0      ! ### imos 1/21/2000
      MZ = 1                          ! ### imos 1/21/2000
      if (JZ/2*2 .eq. JZ) MZ = 0      ! ### imos 1/21/2000
!
        PN = 1.
        IF (MN+MZ .EQ. 2)   PN = 0.85
        IF (MN+MZ .EQ. 0)   PN = 1.25
        IF (MN-MZ .EQ. 1)   PN = 0.90
        JP = IZ - JZ+ 1
        KN = IA - IZ - JN
        IF((JP.GT. 2).OR. (KN.GT. 3).OR. (IA.LT.35))   GO TO 14
        IF (JP.EQ. 2)   GO TO  2
 1    IF (EI.LT.2500.)
     1FE =(1.0 + 2.1*EXP(-(EI/100.)**2) + 0.4*EXP(-EI/350.))*H3
        QH = 24.*(1. + .01*AI)
        QJ = QH
        DX = 3.
        IF (KN .GT. 1)   DX = 15.
        IF (EI.LT.EC)   QJ = QH*FE
        IF (KN.EQ. 1)   GO TO  5
        XN = KN
        XA = 1.17
        IF (IZ.LE.30)  XA=1.6
        QH = QH*EXP(1. - XN**(XA-.0048*AI))
        QJ = QH
        IF (EI.GE.EC)   GO TO  5
        GO TO  4
 2    IF (EJ.LT.2500.)
     1FE =(1.0 - EXP (-(EJ/230.)**2) + 2.2/EXP (EJ/75.)
     1    + .33/EXP (((EJ-900.)/500.)**2))*H3
        QH = 21.
        QJ = QH
        QJ = QH * FE
        IF (KN.EQ. 0)   DX = -3.
        IF (KN.EQ. 1)   DX = -1.
        IF (KN.EQ. 0)   GO TO  5
        IF (KN.GT. 2)   GO TO 14
        IF (IA.GE.35.AND.IA.LE.40.AND.KN.GT.1)  GO TO 14
        QH = 17.
        QJ = QH
        IF (EI.GE.EC)   GO TO  5
 4      KA = IA - JA
        IF (KA.GE. 8)   GO TO  5
        FE = (1. + 1.9/EXP((AA/7.9)**2 + (EI/420.)**1.4))*H3*H4
        QJ = QH*FE
 5      DD = DX*(AI - AM)/ZI
        YA = EXP(DD)
        IF (DD.GT. 0)   YA = 2. - 1./YA
        IF((IA.LT.35).OR. (IA.GT.209))   YA = 1.
        IF((IA.LT.70).AND.(JP.EQ. 3 ))   YA = 1.
        QH = YA*QH
        QJ = YA*QJ
        RETURN
 14     DA = AI - AJ
        IF((JZ.EQ. 7).AND.(JA.EQ.13))     CJ = 0.39
        F1 = 1. - .3*ALOG(AI/20.)
        IF (EI.GE.600.)   F2 = 1.
        IF (EI.LT.600.)   F2 = EXP (.90 - .0015*EI)
        IF (EI.GE.EC)   GO TO 15
        PE = 20./EI**.77
 15     IF (EI.LT.EC)   GO TO 16
        F2 = 1.00
        PE = 1.98/AI**.92
 16     IF (EI.LT.1250.)   RE = 10.2/EI**0.26
      IF (EI.GE.1250.)   RE = 1.60
      Q1 = 27.6*(AI**(2./3.)-1)*F1*F2*PE*RE**.5/(1. - EXP (-PE*AI))
      S  = 0.502 - 0.08*ABS (AI/ZI - 2.)
      T  = 0.0005
      ST = (ZJ - (S - 0.0005*AJ)*AJ)
      ZA = ABS(ZJ - (S - 0.0005*AJ)*AJ)**2
      QJ = Q1*EXP (-PE*DA-RE*ZA)
      QR = QJ*PN*CJ
      QJ = QR
      PH = .77/AI**.667
      RH = 1.60
      QC = 27.6*(AI**(2./3.)-1)* F1*PH*RH**.5/(1. - EXP (-PH*AI))
      QH = QC*EXP (-PH*DA - RH*ZA)*PN*CJ
      IF((JP.NE. 3).OR. (KN.GT. 0).OR. (IA.LT.35))   GO TO 20
      FF = 1.
      FE = 1.
      QJ = QH
 20   IF (IZ.LT.14 .OR. IZ .GT.19 .OR. EI.LT.200.)   RETURN
      IF (EI.GT.500.)  QJ = QJ*(1.+.12*(IZ-13))
      IF (EI.LE.500.)  QJ = QJ*(1.+.12*(IZ-13)*EXP(-((EI-500)/350)**2))
      END
      SUBROUTINE YIELD4(IZ, IA, JZ, JA, EJ, QJ)
C     IZ .GE. 21  AND  JZ .GE. 5
      COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,ANZJ,AA,AE,AC,EC
      COMMON /Q4/ C0, F1, F2, F3, PE, DA, RJ, ZA, PH, YA, Q1, QM, HM
      COMMON /QG/ QI, G1, G2, G3, G4
      COMMON /ST/ ST,S,T2
      DIMENSION   BA(92)
      DATA   BA / 16 * 0 ., 36., 38., 40., 44.
     1,           45., 48., 50., 52., 55.,55.7,58.5, 61., 64., 67.
     1,           70., 73., 75., 78., 80., 82., 84., 86., 89., 92.
     1,           93., 96., 98.,100.,103.,106.,108.,111.,114.,118.
     1,          122.,125.,127.,130.,133.,134.,137.,139.,141.,146.
     1,          146.,149.,153.,156.,159.,161.,165.,166.,169.,172.
     1,          175.,178.,181.,183.,186.,188.,192.,194.,197.,200.
     1,          204.,206.,209.,  0.,0.,0.,0. ,226.,227.,232.,231.,238./
      DATA    S0,S1,T3/.482,.07,3.E-7/,          R0,R1/11.8,0.45 /
      DATA    P0,P1   /1.98, 0.92/,              E0,E1/20.3,1.169/
      DATA    C1,C2,C3,C4/144.,.367,0.3,0.7/,    D1,D2/.0365,1.23/
      T2 = 2.8E-4
      AI = IA
      ZI = IZ
      AJ = JA
      ZJ = JZ
      AM = BA(IZ) + IA*(300/(INT(BA(IZ))+300))
      KM = 0
      FP = 1.
      QJ = 0.
      QR = 0.
      QE = 0.
      QF = 0.
      QM = 0.
      HM = 0.
      QH = 0.
      AC = 0.
      AE = 0.
      DM = 0.
      DX = 0.
      KFLAG = 0
      FE = 1.
      FF = 1.
      FM = 1.
      FA = 1.
      FZ = 1.
      GA = 1.
      CJ = 1.
      PN = 1.
      YA = 1.
      IF((IA.LE.JA).OR.(IZ.LT.JZ).OR.(IA-JA.LT.IZ-JZ))   RETURN
      AA = AI - AJ
      DA = AA
      AN = AJ - ZJ
      ANZJ = AN/ZJ
      ANZI = AI/ZI - 1.
      JN = JA - JZ
      JP = IZ - JZ + 1
      CN = .3*(AI - AM)/ZI
      KN = (IA - IZ) - JN
      XN = KN
!### imos      MN = JN .AND. 1 ! JN,JZ = odd, TRUE =1 ### imos 1/21/2000
!### imos      MZ = JZ .AND. 1 ! JN,JZ = even,FALSE=0 ### imos 1/21/2000
      MN = 1                          ! ### imos 1/21/2000
      if (JN/2*2 .eq. JN) MN = 0      ! ### imos 1/21/2000
      MZ = 1                          ! ### imos 1/21/2000
      if (JZ/2*2 .eq. JZ) MZ = 0      ! ### imos 1/21/2000
!
      IF (MN+MZ .EQ. 2)   PN = 0.85
      IF (MN+MZ .EQ. 0)   PN = 1.25
      IF (MN-MZ .EQ. 1)   PN = 0.90
      PN = PN + (1.-PN)*(1.-EXP(-((IA-100)/35.)**2))
      AC = 31.5 + .045*(AI-36.)*(ALOG(AI)+1.23)
      EI = EJ
      EC = E0*AI**E1
      IF (EC.GT.4000.)   EC = 4000.
      IF (EC.LT.1250.)   EC = 1250.
      IF (EI.GT.  EC )   EI = EC
      FMAX = 1800./EI
      IF (IZ.GE.84)   FMAX = (1800./EI)**(6.56-.067*ZI)
      IF (FMAX .GT. 4.)   FMAX = 4.
      IF (EI.GT.1800.)   FMAX = 1.
      IF (IZ.LE.28 .AND. JZ.EQ.20 .AND. JA.EQ.19)   CJ = 0.6
      IF((JZ.EQ. 7).AND.(JA.EQ.13))   CJ = 0.39
      IF((JZ.EQ.53).AND.(IZ.GE.71).AND.(IZ.LE.83))   CJ = 1.
      P500 = 20./( 500.**.77)
      P1000= 20./(1000.**.77)
      P2000= 20./(2000.**.77)
      P3000= 20./(3000.**.77)
      IF (IZ.EQ.92.AND.JZ.EQ.88)  QH = 1.20*EXP(-.70*ABS(JA-224.))
      IF (IZ.EQ.92.AND.JZ.EQ.89)  QH = 1.60*EXP(-.15*ABS(JA-224.))
      IF (IZ.EQ.92.AND.JZ.EQ.90)  QH = 8.00*EXP(-.25*ABS(JA-233.))
      IF (IZ.EQ.92.AND.JZ.EQ.91)  QH = 18.5*EXP(-.55*ABS(JA-234.))
      IF (IZ.EQ.92.AND.JZ.EQ.92)  QH = 55.0*EXP(-.80*ABS(JA-237.))
      IF (JP .GE. 6 .OR. IA .LT. 35)  GO TO 100
      if (JP.GE.4.AND.JP.LE.5.AND.KN.GE.KM)  GO TO 100
C
C     PERIPHERAL
C
      H3 = 1. - EXP(-(EI/(15. + 10.*AA))**4)
      H4 = 400./EI - 2.2
      IF (H4 .LT. 1.)   H4 = 1.
      IF (H4 .GT. 2.)   H4 = 2.
      HE = (1. + 1.9*EXP(-(DA/7.9)**2 - (EI/420.)**1.4)
     1         -(1.-EXP(-(DA/12.)**8))*EXP(-(EI/420.)**3))*H3*H4
      EC = 2500.
      IF((JP.GE. 3).AND.(JP.LE. 5))   GO TO  3
      IF (JP.EQ. 2)      GO TO  2
 1    IF (EI.LT.2500.)
     1FE =(1.0 + 2.1*EXP(-(EI/100.)**2) + 0.4*EXP(-EI/350.))*H3
      IF (KN .GT. 1)   FE = HE
      KM = AI/20. + 1.5*(ABS(238.-AI)/167.)**2.5 + .8
      IF (IA.LE.70)   KM = 3 + AI/66.
      IF (KN.GT.KM)      GO TO 100
      IF (IA .LE. 40)  QA = 24.0*(1. + .01*AI)
      IF (IA .GT. 40)  QA = 1.02*(AI - 7.)
      IF (IA .GE. 63)  QA = 57.
      QH = QA
      XA = 1.17
      IF (IZ .LE. 30)  XA = 1.5
      IF (KN .NE. 1 )  QH = QA*EXP(1.-XN**(XA-.0048*AI))
      IF (KN .EQ. 1 )  DX = 3.
      IF (KN .GT. 1 )  DX = 15.
      QH = QH*(1. + 0.15*(IZ/80.)**2)
      GO TO 6
 2    FE =(1.0 - EXP(-(EJ/230.)**2) + 2.2*EXP(-EJ/75.)
     1    + .33*EXP(-((EJ-900.)/500.)**2))*H3
      IF (KN .GT. 0 )   FE = HE
      KM = 10.*(1. - EXP(-((AI-39.)/54.5)**2))
      IF (KM.LT. 2)      KM = 2
      IF (IA.GE.35.AND.IA.LE.40.AND.KM.GT.1)  KM = 1
      IF (KN.GT.KM)      GO TO 100
      QH = 17.
        IF (KN.GT. 0 .AND. IZ.LE.50)  QH = 27
        IF (KN.GT. 0 .AND. IZ.GT.50)  QH = 21
        IF (KN.EQ. 0 .AND. IZ.LE.28)  QH = 33
        IF (KN.EQ. 0 .AND. IZ.LE.23)  QH = 28
        IF (KN.EQ. 0 .AND. IZ.LE. 5)  QH = 21
      QJ = QH
      IF (KN.EQ. 0)   DX = -3.
      IF (KN.EQ. 1)   DX = -1.
      GO TO 6
 3    FN = AMIN1((EI/420.)**(.72 - .18*XN)*H3,1.)
      IF (IA .LE. 70)   FE = 1. - EXP(-(EI/35.)**4)
      IF (IA .GT. 70 .AND. KN .LE. 4)   FE = FN
      IF (IA .GT. 70 .AND. KN .GT. 4)   FE = H3
      IF (EI .LT. 200. )   FE = FE*EI/200.
      KM = AI/25. + 0.5
      XM = KM
      IF (KN .GT. KM)   KFLAG = 1
      FM=FE
      IF (KN .LE. 4 )  FM=(EI/420.)**(.72-.18*XM)*H3
      IF (FM .GT. 1.)   FM = 1.
      IF (EI .LT. 200. )   FM = FM*EI/200.
      QH = .2 + 60.*(EXP(-((AI - 89.)/25.)**2-((XN-4.6)/2.)**2)
     1   + (1.-EXP(-(AI/135.)**3))*EXP(-((XN-AI**.46)/AI**.27)**2))
      HM = .2 + 60.*(EXP(-((AI-89.)/25.)**2-((XM-4.6)/2.)**2)
     1   + (1.-EXP(-(AI/135.)**3))*EXP(-((XM-AI**.46)/AI**.27)**2))
      IF (KN.EQ. 0)      DX = -10.
      IF (KN.EQ. 1)      DX = -3.
      IF (IA.LE.70)  GO TO 100
      IF (KN.LE. 2)  QH = (1.2E5/AJ**2.2)*0.12*EXP(XN/0.85)
      IF (KN.GE. 3 .AND. IZ.LE.26)  QH = (1.2E5/AJ**2.2)*EXP((XN-2)/2.)
 4    IF ((JZ.LT.82.AND.KN.GT.KM) .OR. (IZ.GE.88.AND.JP.GT.3))   KFLAG=1
      QH = 0.1**(JP-3)*QH
      HM = 0.1**(JP-3)*HM
 6    IF (EI .GE. EC)   FE = 1.
      IF (DX*(AI-AM) .LE. 0)  YA = EXP(DX*(AI-AM)/ZI)
      IF (DX*(AI-AM) .GT. 0)   YA = 2. - EXP(-DX*(AI-AM)/ZI)
      IF (JP.GE.3 .AND. IA.LE.70)   YA = 1.
 10   IF (IA.GT.157.AND.EI.GT.500.AND.JP*KN.NE.1)
     1YA = YA*(1. - .012*(AI-157.)*(1. - EXP(-((EI-500.)/290.)**2)))
     1       *(1. - EXP(-0.6*(1.*JP)**.8-((92.-ZI)/2.7)**2))
      QH = QH*YA
      IF (IZ.EQ.92.AND.JZ.EQ.88)  QH = 1.20*EXP(-.70*ABS(JA-224.))
      IF (IZ.EQ.92.AND.JZ.EQ.89)  QH = 1.60*EXP(-.15*ABS(JA-224.))
      IF (IZ.EQ.92.AND.JZ.EQ.90)  QH = 8.00*EXP(-.25*ABS(JA-233.))
      IF (IZ.EQ.92.AND.JZ.EQ.91)  QH = 18.5*EXP(-.55*ABS(JA-234.))
      IF (IZ.EQ.92.AND.JZ.EQ.92)  QH = 55.0*EXP(-.80*ABS(JA-237.))
      IF (JP.GT.5 .OR. (JP.GT.3.AND.IZ.GE.88))  GO TO 100
      QJ = QH*FE
      HM = HM*YA
      QM = HM*FM
        IF (KFLAG.EQ.0)  GO TO 200
 100  EC = E0*AI**E1
      IF (EC.GT.4000.)  EC=4000.
      IF (IA.GT.100)  FP = 1. - 0.20*(IA-100)/100.
      IF (IA.GT.180)  FP = 0.84
      ANZX = AMIN1(ANZJ,ANZI)
      ANZC = ANZJ - CN
      IF (ANZC .GT. 1.5)  ANZC = 1.5
      AZ = ANZJ
      EE = 450./EI
      IF (JA.GT.36 .AND. JZ.LT.88 .AND. IZ.EQ.92)
     1  FF = EXP(33.*((ANZJ - 1.36)+.00006*EI-1200./(EI+80.)**2))
      IF (JA.GT.36 .AND. JZ.LT.88 .AND. IZ.EQ.90)
     1  FF = EXP(16.*EE**.6*((ANZJ-CN)+.00006*EI - 1200./(EI+80)**2))
      IF (JA.GE.36 .AND. JZ.LT.IZ .AND. IZ.GE.84 .AND. IZ.LT.90)
     1  FF = EXP(19.*EE**.6*((ANZX-CN)-ALOG(5.5/EI**.07)))
      GE = EE
      H1 = AJ - 105. + .68*(207.-AI)
      IF (EI .LE. 200.)   GE = 2.25
      IF (EI .GT. 450. .AND. EI .LT. 600.)  H1 = .0006*H1*(600. - EI)
      IF (EI .LE. 450.)                     H1 = .0900*H1
      IF (EI .GE. 600. .OR.  AI .LT. 180. .OR . H1 .LT. 0)   H1 = 0
      AE=.0065*(207-IA)*EXP(-ABS(EI-700.)/700.)
      IF (IA.GE.110 .AND. IZ.LE.83 .AND. JZ.LT.IZ)
     1FF = EXP(19.*EE**.6*((ANZX-CN)-ALOG(5.5/EI**.07) - AE)
     1         -(((AJ/AI-.46)/.15)**2*GE+H1))
      IF (IA.GE.110 .AND. IZ.LE.83 .AND. JZ.LT.IZ .AND. ANZX-CN.LT.1.3)
     1    FF = FF*EXP((1.3-ANZX+CN)*(350./EI)**4/(1. + (130./EI)**4))
      IF (FF.GT.FMAX)    FF = FMAX
      IF (JZ.GE.88)      GO TO 110
      EE = EI/EC
      A4 = (AI/63.)**4
      IF (EE.GE..3)      FE = EE**(2.2 - .01*A4)
      IF (EE.LT..3)      FE = EE**(2.2 + .01*A4)*.3**(-.02*A4)
      IF ((JZ.GE. 5).AND.(JZ.LE. 8))   FE = EE**1.8
      IF ((JZ.GE. 9).AND.(JZ.LE.10))   FE = EE**2.0
      GF = 1.
      EX = EI
      IF (EX .LT. 500.)  EX = 500.
      IF((JA.GE.18).AND.(JA.LE.30))
     1GF = EXP(2600.*((ANZX-CN)+.01*AI-3.1)/EX)
      IF((JA.GE.31).AND.(JA.LE.56))
     1GF = EXP(5600.*((ANZX-CN)+.0035*AI-1.72)/EX)
      IF(GF .LT. 1.)  GF = 1.
      FE = FE*GF
      IF((JZ.LT.30).OR.  (IZ.LE.83))      GO TO 140
C
C     URANIUM GROUP, ZP .GT. CU
C
 110  FU=1.
      IF (IZ.GE.88 .AND. JZ.GE.82 .AND. (KN.GT.KM .OR. JP.GT.3) )
     1FU=(1.-EXP(-.6*(1.*JP)**.8-((92.-ZI)/2.7)**2))
     1  *(1.-0.8*(EXP(-((ZI-ZJ)/5.4)**8)))
      IF (IZ.GE.88 .AND. JZ.GE.57 .AND. JZ.LT.82)
     1FU=1.0-0.36*EXP(-((82.-ZJ)/27.)**2-((92.-ZI)/2.7)**2)
      CJ=CJ*FU
 120  IF((JZ.GE.30).AND.(JZ.LE.35))
     1  QH =  6.5*EXP(- 80.*(AN/ZJ - 1.26)**2)*PN
      IF((JZ.GE.36).AND.(JZ.LE.43))
     1  QH = 10.0*EXP(- 55.*(AN/ZJ - 1.33)**2)*PN
      IF((JZ.GE.44).AND.(JZ.LE.50))
     1  QH = 10.0*EXP(- 70.*(AN/ZJ - 1.36)**2)*PN
      IF (JZ.LE.50)    GO TO 130
      EE = EI - 100
      IF (EE .LT. 150.)  EE = 150.
      HE = .03*(ALOG(EE))**2
      IF (HE.GT. 1.)   HE = 1.
      ZZ = JZ
      IF (JZ .LT. 55)  ZZ = 55.
      HS = (1.5*EXP(-1.0/ZJ*(ZZ-55.)**2) + 3.0) * FU * HE
      HF =  5.0*EXP(-10./ZJ*(ZZ-55.)**1.5)
      CON = 80. + 220.*(1. - EXP(-(ZJ-55.)**2/4.))*(JZ/55)
      IF((JZ.GE.51).AND.(JA.LE.155))
     1  QH = HF*EXP(-CON *(AN/ZJ - 1.48)**2)*PN
     1     + HS*EXP(-260.*(AN/ZJ - 1.29)**2)*PN
      IF((JZ.GE.66).AND.(JZ.LE.87))   GO TO 140
      IF (IZ.LT.88)  GOTO 140
      QJ = QH
      IF (IZ .LE. 90)   QH = 0.6*QH
 130  QF = QH*FF
      QJ = QF
      GO TO 200
C
 140  IF (IZ.GE.29 .AND. JZ.EQ. 5)  FA = EXP(.02*(AI-56)*(ANZC-0.6))
      IF((IZ.GE.29).AND.(JZ.GE. 6).AND.(JZ.LE. 8))
     1    FA = EXP (.020*(AI - 56.)*(ANZC-0.7))
      IF((IZ.GE.29).AND.(JZ.GE. 9)             )
     1    FA = EXP (.020*(AI - 56.)*(ANZC-0.9))
      IF (JZ.LE.11)      FA = FA*EXP(-2.5*(ANZC-1.))
      IF (FA.LT.1.)      FA = 1.0
      IF (IA.GE.110)     FM = FF
      IF (IA.LT.110)     FM = FE
      IF((IA.GE.110).AND.(JA.LT.57).AND.(AJ.GT.0.23*AI)) FM=AMAX1(FE,FF)
      IF((IA.GE.110).AND.(JA.LT.57).AND.(AJ.LE.0.23*AI)) FM=FE
      DMAX = 31.5 + .045*(AI - 36.0)*(ALOG(AI) + 1.23)
      AC = DMAX
      AE = AC
      AH = DA
      IF (AH .GT. DMAX)   AH = DMAX
      IF (EI .LT. EC)  DMAX = 31.5 + D1*(AI-36)*(ALOG(EI) - D2)
      AE = DMAX
      IF (DA.GT.DMAX)    DA = DMAX
 150  F1 = EXP(-.25 + .0074*AI)
      IF (EI.GT.750.)    F1 = 1.00 + (F1 - 1.00)*((EC-EI)/(EC-750.))**2
      IF (EI.GE. EC )    F1 = 1.00
      F2 = EXP(1.73 - .0071*EI)
      IF (F2 .LT. 1.)  F2 = 1.
      PE = 20./EI**.77
      PH = P0 /AI**P1
      IF((IZ.GE.20).AND.(IZ.LE.30))
     1PE = PE*(1. - .32*EXP (-((EI - 100.)/100.)**2))
      IF (IA.GT.100)
     1PE = PE*(1. - .000015*(AI-100.)*(EC+150.)/(EI+150.))
      IF (IA.LE.71 .AND. EJ.GE.  EC )  PE = PH
      IF (IA.GT.72 .AND. EJ.Ge.3000.)  PE = PH
      IF (EJ.GE.EC .AND. EJ.GE.3000.)  PE = PH
      PA = PE * AI
      HA = PH * AI
      RJ = R0*AJ**(-R1)*(1.-0.4*(IZ/88))
      IF (AJ .LT. 40.)  RJ = 1.29*AJ**.15*(1.-0.4*(IZ/88))
      IF((AA.LT.AC).AND.(JZ.EQ.40))  DM =-1.1
      IF((AA.LT.AC).AND.(JZ.EQ.42))  DM = 0.8
      IF((AA.LT.AC).AND.(JZ.EQ.53))  DM =-0.5
      IF((AA.LT.AC).AND.(JZ.EQ.55))  DM = 1.7
      IF((AA.LT.AC).AND.(JZ.EQ.60))  DM =-1.1
      IF((AA.LT.AC).AND.(JZ.EQ.61))  DM =-1.3
      IF((AA.LT.AC).AND.(JZ.EQ.63))  DM = 0.9
      IF((AA.LT.AC).AND.(JZ.EQ.64))  DM = 0.7
      IF((IZ.GT.76).AND.(JZ.GT.62))  DM = DM + 1.
      AJ = AJ + DM
      S  = S0 - S1*(AI - AM)/ZI
      ST = ZJ - (S - T2*AJ - T3*AJ*AJ)*AJ
      IF (ST .LT.-1.)  ZA = ABS(ST)**1.30
      IF (ST .GE.-1.)  ZA = ABS(ST)**1.50
      IF (ST .GT. 1.)  ZA = ABS(ST)**1.75
      Q0 = C1*F1*F2*PE*AI**C2/(1.-C3/PA-(C4-C3/PA)*EXP(-PA))
      H0 = C1*1.00 *PH*AI**C2/(1.-C3/HA-(C4-C3/HA)*EXP(-HA))
      QR = CJ*PN*EXP(-PE*DA-RJ*ZA) * Q0
      QH = CJ*PN*EXP(-PH*AH-RJ*ZA) * H0
      AX = 0.5*(S - SQRT(S*S - 4.*T2*ZJ))/T2 - DM
      KX = (AI - AX) - (JP-1)
      XP = KX
      IF (IA.GT.70.AND.KN.GT.KM.AND.KN.LT.KX.AND.KFLAG.EQ.1) GOTO 155
      KFLAG=0
      IF (EJ.GT.EC)   QR = QH
      IF (EI.GE.2500. .AND. QR.GT.QH)  QR=QH
      F500=EXP(.0074*AI-.25)
      Q500 =CJ*PN*C1*F500 *AI**C2*P500 *EXP(-P500 *DA-RJ*ZA)
     &     /(1.-C3/P500 /AI-(C4-C3/P500 /AI)*EXP(-P500 *AI))
      F1000= 1.+(EXP(.0074*AI-.25)-1.)*((EC-1.E3)/(EC-750.))**2
      Q1000=CJ*PN*C1*F1000*AI**C2*P1000*EXP(-P1000*DA-RJ*ZA)
     &     /(1.-C3/P1000/AI-(C4-C3/P1000/AI)*EXP(-P1000*AI))
      F2000= 1.+(EXP(.0074*AI-.25)-1.)*((EC-2.E3)/(EC-750.))**2
      Q2000=CJ*PN*C1*F2000*AI**C2*P2000*EXP(-P2000*DA-RJ*ZA)
     &     /(1.-C3/P2000/AI-(C4-C3/P2000/AI)*EXP(-P2000*AI))
      F3000= 1.+(EXP(.0074*AI-.25)-1.)*((EC-3.E3)/(EC-750.))**2
      Q3000=CJ*PN*C1*F3000*AI**C2*P3000*EXP(-P3000*DA-RJ*ZA)
     &     /(1.-C3/P3000/AI-(C4-C3/P3000/AI)*EXP(-P3000*AI))
      FDAE = AMIN1((AI-AJ)/(.14*AI)*(EI/1000.)**(-2./3.),2.)
        FDAE1 = (AI-AJ)/(.14*AI)
      IF (IZ.GE.29.AND.IZ.LE.83.AND.EI.LE.1.E3)   QR = QR*FDAE
      IF (IZ.GE.29.AND.IZ.LE.83.AND.EI.GE.1.E3.AND.EI.LE.3.E3)
     &  QR = Q1000*FDAE1 + (QH-Q1000*FDAE1)*((EI-1000)/2000.)
      QJ = QR
      QI = QR
      IF (IZ.LT.88 .OR. JP.GT.3)  GOTO 160
      QJ = QR*FU
      GO TO 200
 155  F1000=1.00+(EXP(.0074*AI-.25)-1.00)*((EC-1000.)/(EC-750.))**2
      Q1000=CJ*PN*C1*F1000*AI**C2*P1000*EXP(-P1000*DA-RJ*ZA)
     1     /(1.-C3/P1000/AI-(C4-C3/P1000/AI)*EXP(-P1000*AI))
      X1000=Q1000*EXP(-P1000*(AI-AX))/EXP(-P1000*DA-RJ*ZA)
      HR=QH*EXP(-PH*(AI-AX))/EXP(-PH*AH-RJ*ZA)
      IF (X1000.GT.HR)  X1000=HR
      F500 =EXP(.0074*AI-.25)
      Q500 =CJ*PN*C1*F500*AI**C2*P500*EXP(-P500*DA-RJ*ZA)
     1     /(1.-C3/P500/AI-(C4-C3/P500/AI)*EXP(-P500*AI))
      X500=Q500*EXP(-P500*(AI-AX))/EXP(-P500*DA-RJ*ZA)
      QR=QR*EXP(-PE*(AI-AX))/EXP(-PE*DA-RJ*ZA)
      IF (EI.GT.EC)                QR=HR
      IF (EI.GE.1000. .AND. QR.GT.HR) QR=HR
      IF (EI.LT.1000. .AND. EI.GT.500.)
     1QR=X500+(X1000-X500)*(EI-500.)/500.
      QH=HM+(HR-HM)*(XN-XM)/(XP-XM)
      QJ=QM+(QR-QM)*(XN-XM)/(XP-XM)
      KFLAG=0
      GO TO 200
 160  DD = AC - AA
      XZ = 1.29 + 0.005*DD + CN
      IF (QH .GT. 0.)  RH = QR/QH
      IF (GF .GT. 0.)  FR = FE/GF
      IF((IA.GE. 69).AND.(RH.LT.FR).AND.(EI.LT.300.))  QR = QH*FR
      IF (IZ.GE.76.AND.IZ.LE.80) FF=FF*AMIN1(1050./EI+EI/EC,6.)
      IF((IA.GE.110).AND.(IA.LE.238))   QF = QH*FF*FA
      IF((IA.GE. 69).AND.(JA.LE. 57))   QE = QH*FE*FA
      IF (IA.LT.110. OR. IA.GT.209 .OR. JA.LE.56)  GO TO 190
      IF (DD.GE. 20)                               GO TO 170
      IF (IA.LE.125)                               GO TO 180
      IF (AZ.LE.XZ .OR. JZ.GT.57)                  GO TO 170
      KZ=51+IZ/76+IZ/80
      IF (AZ.GT.XZ .AND.JZ.LT.KZ)                  GO TO 180
      ER = EI**(2./3.)
      IF (ANZC.LT.1.56)  GA = (.03 + (ZJ-KZ)*.007)*(1.56-ANZC)*ER
      IF (ANZC.GE.1.56)  GA = 0
      IF (GA  .GT.  1.)  GA = 1.
      IF((JZ.GE. KZ).AND.(JZ.LE.57).AND.(DD.LT.20.).AND.(AZ.GT.XZ))
     1    QJ = QR**GA*QF**(1.-GA)
      GO TO 200
 170  QJ = QR
      GO TO 200
 180  QJ = AMAX1(QR, QF)
      GO TO 200
 190  IF((IA.GE.210).AND.(JA.GE.57))                         QJ=QF
      IF((IA.GE.110).AND.(JA.LE.56).AND.(AJ.GT.0.23*AI))     QJ=QH*FA*FM
      IF((IA.GE.110).AND.(JA.LE.56).AND.(AJ.LE.0.23*AI))     QJ=QE
      IF((IA.LT.110).AND.(IA.GE.69).AND.(DD.GE. 0 ))         QJ = QR
      IF((IA.LT.110).AND.(IA.GE.69).AND.(DD.LT. 0 ))         QJ = QE
      IF (IA.LT. 69)                                         QJ = QR
      IF (QJ.EQ.QR .AND. QI.GT.0.)   QH = QH*QR/QI + .000001
      IF((IZ.GE.90).AND.(JZ.GE.66))
     1QJ = HF*EXP(-CON*(AN/JZ - 1.48)**2)*PN*(0.6+0.2*(IZ-90))
     1      + HS*EXP(- RJ*ZA )*PN*(0.6+0.2*(IZ-90))
      IF((QJ.EQ.QE).OR. (QJ.EQ.QF))   GA = 0.
      IF (QJ.EQ.QR)                   GA = 1.
      IF (JP.LT.3 .OR. JP.GT.5)   GO TO 200
      FE = 1. - EXP(-(EI/35.)**4)
      IF (EI .LT. 200.)   FE = FE*EI/200.
      IF (JP.GE.3 .AND. KN.GE.1 .AND. IA.LE.70)   GO TO 200
        IF (IZ.GT.30.AND.JP.GE.3.AND.KN.GE.KM)  GO TO 200
      QJ = QH*FE*YA
 200  EX = E0*56.**E1*EJ/EC
      G1 = 1.-0.6*(1.-EXP(-(EX/1000.)**2))*EXP(-(EX/2000.)**2)
     1       +0.2*(1.-EXP(-(EX/3000.)**2))
      G2 = 1.-0.4*(1.-EXP(-(EX/2000.)**2))*EXP(-((EX-1800.)/1800.)**2)
     1       +.17*(1.-EXP(-(EX/2000.)**2))
      G3 = 1.+.25*(1.-EXP(-(EX/1500.)**2))*EXP(-((EX-1500.)/1800.)**2)
     1       -.05*(1.-EXP(-(EX/2000.)**2))
      G4 = 1.-0.1*(1.-EXP(-(EX/4000.)**2))
      IF (IZ.LE.28 .AND. JZ.LE.4 .AND. JA.LE.12)  QJ=QJ*G1
      IF (IZ.LE.28 .AND. AA.GT.AC)                QJ=QJ*G2
      IF (IZ.GT.28 .AND. JA.LE.56 .AND. AA.GT.AC) QJ=QJ*G2
      IF (AA.GE.7. .AND. AA.LE.AC-13.)            QJ=QJ*G3
      IF (IZ.GE.90 .AND. JA.GT.56 .AND. AA.GE.7.) QJ=QJ*G4
      MX=10
      IF (IA.LT.150.AND. JP.LT. 3)  MX=9
      IF (IA.GE.150.AND. JP.EQ. 3)  MX=11
      IF (JP.EQ. 1 .AND. KN.GT.MX)  QJ=QJ*(.1+.9*EXP(-(XN-MX)**2/4.))
      IF (JP.EQ. 2 .AND. KN.GE.MX)  QJ=QJ*(.1+.9*EXP(-(XN-MX)**2/4.))
      IF (JP.EQ. 3 .AND. KN.GE.MX)  QJ=QJ*(.5+.5*EXP(-(XN-MX)**2/4.))
      QJ = QJ*FP
      END
      SUBROUTINE PXN(Z, A, X, E, QJ)
      COMMON /A/ Q1, Q2, QI, F1, F2, F3
      EI = 500. + 300.*X
      Q1 = 3.3*EXP(-ABS(6.9-X)**2.8/67.45-90*X**2.35*ABS(2.5-A/Z)**5)
      QA = 3.3*EXP(-ABS(6.9-X)**2.8/67.45 - .04638*X**2.35)
      QB = 3.3*EXP(-ABS(6.9-X)**2.8/67.45)
      IF (A/Z.GE.2.28 .AND. A/Z.LE.2.50)
     1Q1 = QA**((2.5-A/Z)/0.22) * QB**((A/Z-2.28)/0.22)
      IF (A/Z .GT. 2.5)   Q1 = QB
      QI = Q1
      XZ = ((A - Z) - X + 1)/Z
      Q2 = 0.5*EXP(-90.*ABS(1.5-XZ)**5)
      IF (XZ .LE. 1.2)   QI = AMIN1(Q1, Q2)
      FI = 1.0                                          !### imos 1/21/2000
      IF (Z  .GE. 81.)   FI = 1.5*EXP(-X*((Z-80.)/12.)**5)
      IF (FI .GT. 1.0)   FI = 1.
      IF (Z  .GE. 81.)   QI = QI*FI
      IZ = Z +.1
      NX = X +.1
      IA = A +.1
      NT = IA-IZ
      N  = NT-NX
      ED = E
      IF (NX.GE.3 .AND. IZ.GE.39 .AND. NT.GE.28 .AND. N .LT.50)
     1    ED = E - 10.
      IF (NX.GE.3 .AND. IZ.GE.59 .AND. NT.GE.50 .AND. N .LT.82)
     1    ED = E - 3.
      B  =  A
      IF (B .LT. 35.)   B = 35.
      FX = (12.+.1*X)*X - (1.-1./X**.5)*B**(2./3.)
      ALOGY=(1.+1.5*X)*ALOG(ABS(ED/FX))
      IF (ALOGY .GT. 10.)  ALOGY=10.
      F1 = 1. - EXP(-EXP(ALOGY))
      C  = 1. + 0.03*X*(A-208.)
      IF (C .LE. 1.)   C = 1.
      D  =  27.5 - 0.1*(A + (200.-A)/X**.5)
      IF ((1.-X)*(208.-A) .GT. 0)   D = D - 0.03*(1.-X)*(208.-A)
      F  = E
      IF (NX.GE.3 .AND. IZ.GE.39 .AND. NT.GE.28 .AND. N .LT.50)
     1    F = E - 3.
      IF (NX.GE.3 .AND. IZ.GE.59 .AND. NT.GE.50 .AND. N .LT.82)
     1    F = E - 3.
      IF (NX.EQ.1 .AND. IZ.GE.79 .AND. IZ.LE.83)  F = E + 5.
      F2 = 3500/C * EXP(-.6*X-.5*(((F-D)-5.*X**1.34)/(6.-2.5/X**4))**2)
     1             * (1. - EXP(-(0.03*A/(2.-1./X**4))**3))
      G  =  0.01*(A-208.)
      IF (A .LT. 208.)   G = 0.
      F3 = (1300./(E + 20.*X**1.5/E))**(1.3 - G)
      FH = (1300./(EI+20.*X**1.5/EI))**(1.3-G)
      FE = F1*(F2 + F3)
      IF (E .GE. EI)   QJ = FH*QI
      IF (E .LT. EI)   QJ = FE*QI
      IF (Z.EQ.6. .AND. A-X+1..EQ.13.)   QJ = QJ*0.4
      IF (Z.EQ.3. .AND. A-X+1..EQ. 9.)   QJ = QJ*0.65
      END


C
C This file is part of the GROMACS molecular simulation package.
C
C Copyright (c) 1991-2001
C BIOSON Research Institute, Dept. of Biophysical Chemistry
C University of Groningen, The Netherlands
C Copyright (c) 2012, by the GROMACS development team, led by
C David van der Spoel, Berk Hess, Erik Lindahl, and including many
C others, as listed in the AUTHORS file in the top-level source
C directory and at http://www.gromacs.org.
C
C GROMACS is free software; you can redistribute it and/or
C modify it under the terms of the GNU Lesser General Public License
C as published by the Free Software Foundation; either version 2.1
C of the License, or (at your option) any later version.
C
C GROMACS is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
C Lesser General Public License for more details.
C
C You should have received a copy of the GNU Lesser General Public
C License along with GROMACS; if not, see
C http://www.gnu.org/licenses, or write to the Free Software Foundation,
C Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA.
C
C If you want to redistribute modifications to GROMACS, please
C consider that scientific software is very special. Version
C control is crucial - bugs must be traceable. We will be happy to
C consider code for inclusion in the official distribution, but
C derived work must not be called official GROMACS. Details are found
C in the README & COPYING files - if they are missing, get the
C official version at http://www.gromacs.org.
C
C To help us fund GROMACS development, we humbly ask that you cite
C the research papers on the package. Check out http://www.gromacs.org.

C
C     This code is meant to be called from C routines.
C     Therefore all indices start at 0, although the arrays
C     start at 1, if an array contains an index we must add 1 to it.
C     EG: jjnr points to particles starting at 0
C         type is indexed from 1 to ...
C

      subroutine FORLJC(ix,iy,iz,qi,
     $     pos,nj,type,jjnr,charge,nbfp,
     $     faction,fip,
     $     Vc,Vnb)

      implicit none

      real      ix,iy,iz,qi
      real      pos(*),charge(*),faction(*),fip(3)
      integer*4 nj,jjnr(*),type(*)
      real      Vc,Vnb,nbfp(*)

      integer   k,jnr,j3,tj
      real      twelve,six
      real      fX,fY,fZ
      real      rijX,rijY,rijZ
      real      fijscal,vijcoul
      real      vctot,vnbtot
      real      rinv1,rinv2,rinv6
      real      fjx,fjy,fjz
      real      tx,ty,tz,vnb6,vnb12

      parameter(twelve=12.0,six=6.0)

      fX     = 0
      fY     = 0
      fZ     = 0
      vctot  = 0
      vnbtot = 0

cray compiler directive ignore vector dependencies
c$dir ivdep
      do k=1,nj
         jnr   = jjnr(k)+1
         j3    = 3*jnr-2
         rijX  = ix - pos(j3)
         rijY  = iy - pos(j3+1)
         rijZ  = iz - pos(j3+2)

         rinv1       = 1.0/sqrt((rijX*rijX)+(rijY*rijY)+(rijZ*rijZ))
         rinv2       = rinv1*rinv1
         rinv6       = rinv2*rinv2*rinv2

         tj          = 2*type(jnr)+1
         vnb6        = nbfp(tj)*rinv6
         vnb12       = nbfp(tj+1)*rinv6*rinv6
         vijcoul     = qi*charge(jnr)*rinv1

         vctot       = vctot+vijcoul
         vnbtot      = vnbtot+vnb12-vnb6
         fijscal     = (twelve*vnb12-six*vnb6+vijcoul)*rinv2

         fjx           = faction(j3)
         tx            = rijX*fijscal
         fX            = fX + tx
         faction(j3)   = fjx - tx
         fjy           = faction(j3+1)
         ty            = rijY*fijscal
         fY            = fY + ty
         faction(j3+1) = fjy - ty
         fjz           = faction(j3+2)
         tz            = rijZ*fijscal
         fZ            = fZ + tz
         faction(j3+2) = fjz - tz

      end do

      fip(1) = fX
      fip(2) = fY
      fip(3) = fZ
      Vc     = Vc  + vctot
      Vnb    = Vnb + vnbtot

      return

      end

      program main

      implicit none

      integer maxatom,maxx,maxlist,maxtype
      parameter(maxatom=1000,maxx=3*maxatom,maxlist=100)
      parameter(maxtype=19)

      real*4 ix,iy,iz,qi,pos(maxx),faction(maxx),fip(3)
      real*4 charge(maxatom),nbfp(2*maxtype),Vc,Vnb
      integer type(maxatom),jjnr(maxlist)
      integer i,i3,j

c     setup benchmark
      do i=1,maxtype
         nbfp(2*i-1) = 1e-3
         nbfp(2*i)   = 1e-6
      end do

      type(1)=1
      do i=2,maxatom
         type(i)=1+mod(type(i-1)+91,maxtype)
      end do

      do i=1,maxatom
         i3=3*(i-1)
         pos(i3+1) = i
         pos(i3+2) = i
         pos(i3+3) = 1

         charge(i) = mod(i,2)-0.5
      end do

      jjnr(1) = 13
      do i=2,maxlist
         jjnr(i) = mod(jjnr(i-1)+13,maxatom)
      end do

      ix = 0.0
      iy = 0.0
      iz = 0.0
      qi = 1.0
      Vc = 0.0
      Vnb= 0.0

c     run it

      do j=1,100
         do i=1,maxatom

            call FORLJC(ix,iy,iz,qi,
     $           pos,maxlist,type,jjnr,charge,nbfp,
     $           faction,fip,
     $           Vc,Vnb)

         end do
      end do

      print *,Vc, Vnb

      stop
      end


      SUBROUTINE REINIT(ISUB)
*
*
*       Re-initialization of chain system.
*       ----------------------------------
*
      INCLUDE 'common6.h'
        REAL*8  M,MASS,MC
        PARAMETER (NMX=10,NMX2=2*NMX,NMX3=3*NMX,NMX4=4*NMX,
     &  NMX8=8*NMX,NMXm=NMX*(NMX-1)/2)
         COMMON/ARCHAIN/XCH(NMX3),VCH(NMX3),WTTL,M(NMX),
     &   XCDUM(NMX3),WCDUM(NMX3),MC(NMX),
     &   XI(NMX3),VI(NMX3),MASS,RINV(NMXm),RSUM,INAME(NMX),NN
      COMMON/CHAINC/  XC(3,NCMAX),UC(3,NCMAX),BODYC(NCMAX),ICH,
     &                LISTC(LMAX)
      COMMON/CHREG/  TIMEC,TMAX,RMAXC,CM(10),NAMEC(NMX),NSTEP1,KZ27,KZ30
      COMMON/CLUMP/   BODYS(NCMAX,5),T0S(5),TS(5),STEPS(5),RMAXS(5),
     &                NAMES(NCMAX,5),ISYS(5)
      COMMON/ECHAIN/  ECH
      REAL*8  FIRR(3),FD(3)
*
*
*       Set phase indicator for step reduction (routine STEPS).
      IPHASE = 10
*
*       Re-initialize neighbour list of c.m. and form perturber list.
      RS0 = RS(ICH)
      CALL NBLIST(ICH,RS0)
      CALL CHLIST(ICH)
      NNB1 = LIST(1,ICH) + 1
*
*       Predict neighbours to FDOT and c.m. to FDOT3.
      DO 1 L = 2,NNB1
          J = LIST(L,ICH)
          CALL XVPRED(J,0)
    1 CONTINUE
      CALL XVPRED(ICH,-1)
*
*       Initialize force polynomials (include differential force correction).
      CALL FPOLY1(ICH,ICH,0)
      DO 5 K = 1,3
          FIRR(K) = 0.0
          FD(K) = 0.0
    5 CONTINUE
      CALL CHFIRR(ICH,2,X(1,ICH),XDOT(1,ICH),FIRR,FD)
      DO 10 K = 1,3
          F(K,ICH) = F(K,ICH) + 0.5*FIRR(K)       !factorial bugs 4/7/07
          FDOT(K,ICH) = FDOT(K,ICH) + ONE6*FD(K)
   10 CONTINUE
      CALL FPOLY2(ICH,ICH,0)
*
*       Obtain maximum unperturbed separation based on dominant neighbour.
      CALL EXTEND(ISUB)
*
*       Update chain variables (just in case).
      CALL XCPRED(0)
*
*       Update decision-making variables for chain regularization.
      TS(ISUB) = TIME
*       Note: probably done on next CALL CHAIN.
***   STEPS(ISUB) = 0.01*STEP(ICH)
*
*       Re-calculate new energy of chain system (not needed!).
*     CALL CONST(XCH,VCH,M,NN,ECH1,ANG,ALAG)
*
*       Set phase indicator < 0 to ensure new NLIST in routine INTGRT.
      IPHASE = -1
*
      RETURN
*
      END


! -*- F90 -*-

      subroutine SMRSPevolve(xin,qin,pdf)
      include 'parmsetup.inc'
      PARAMETER(NX=50)
      PARAMETER(NQ=19)
      real*8 xin,qin,pdf(-6:6),xval(45),qcdl4,qcdl5
      real*8 upv,dnv,usea,dsea,str,chm,bot,top,glu
      real*8 SIG,QNS,GL
      real*8 holdit
      real*8 f
      common /SMRSP/ F(7,NX,NQ,3)
      character*16 name(nmxset)
      character*1 dummy
      integer nmem(nmxset),ndef(nmxset),mmem
      common/NAME/name,nmem,ndef,mmem
      integer nset
      integer initread
      DATA initread/0/
      save

      call getnset(iset)
      call getnmem(iset,imem)

      iimem = imem
      if(iimem.eq.0) iimem = 2
      if(iimem.le.3) then
       call SMRSPxx(iimem,xin,qin,upv,dnv,usea,str,chm,bot,glu)
      endif

      pdf(-6)= 0.0d0
      pdf(6)= 0.0d0
      pdf(-5)= bot
      pdf(5 )= bot
      pdf(-4)= chm
      pdf(4 )= chm
      pdf(-3)= str
      pdf(3 )= str
      pdf(-2)= usea
      pdf(2 )= upv+usea
      pdf(-1)= usea
      pdf(1 )= dnv+usea
      pdf(0 )= glu

      return
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      entry SMRSPread(nset)
      read(1,*)nmem(nset),ndef(nset)
      do j=1,3
      do k=1,NX
      do l=1,NQ
      if(initread.eq.0) then
        read(1,*)(F(m,k,l,j),m=1,5),F(7,k,l,j),F(6,k,l,j)
      else
        read(1,'(a1)')dummy
      endif
      enddo
      enddo
      enddo
      initread=1
      return
!
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      entry SMRSPalfa(alfas,qalfa)
        call getnset(iset)
        call getnmem(iset,imem)
        call GetOrderAsM(iset,iord)
        call Getlam4M(iset,imem,qcdl4)
        call Getlam5M(iset,imem,qcdl5)
        call aspdflib(alfas,Qalfa,iord,qcdl5)
      return
!
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      entry SMRSPinit(Eorder,Q2fit)
      return
!
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      entry SMRSPpdf(mem)
!      imem = mem
      call getnset(iset)
      call setnmem(iset,mem)
      return
!
 1000 format(5e13.5)
      END
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
      SUBROUTINE SMRSPxx(iset,X,SCALE,UPV,DNV,SEA,STR,CHM,BOT,GLU)
!
! ::::::::::::  PION STRUCTURE FUNCTION :: 10% SEA :::::::::::::::::
!
      implicit real*8 (a-h,o-z)
      PARAMETER(NX=50)
      PARAMETER(NQ=19)
      PARAMETER(NTENTH=21)
      common /SMRSP/ F(7,NX,NQ,3)
      DIMENSION G(7),XX(NX),N0(7),XX0(NX)
!      DIMENSION F(7,NX,NQ),G(7),XX(NX),N0(7)
      DATA XX/1.D-5,2.D-5,4.D-5,6.D-5,8.D-5,                            &
     &        1.D-4,2.D-4,4.D-4,6.D-4,8.D-4,                            &
     &        1.D-3,2.D-3,4.D-3,6.D-3,8.D-3,                            &
     &        1.D-2,2.D-2,4.D-2,6.D-2,8.D-2,                            &
     &     .1D0,.125D0,.15D0,.175D0,.2D0,.225D0,.25D0,.275D0,           &
     &     .3D0,.325D0,.35D0,.375D0,.4D0,.425D0,.45D0,.475D0,           &
     &     .5D0,.525D0,.55D0,.575D0,.6D0,.65D0,.7D0,.75D0,              &
     &     .8D0,.85D0,.9D0,.95D0,.975D0,1.D0/
      DATA XMIN,XMAX,QSQMIN,QSQMAX/1.D-5,1.D0,5.D0,1310720.D0/
      DATA N0/0,0,3,5,0,5,0/
      DATA ZEROD/0.D0/,PONED/0.1D0/,ONED/1.D0/,ONEDO/1.1D0/,TWOD/2.D0/
      DATA INIT/0/
      save
      XSAVE=X
      IF(INIT.NE.0) GOTO 10
      INIT=1
      do n=1,nx
        xx0(n)=xx(n)
      enddo
      do jset=1,3
      DO 20 N=1,NX-1
      DO 20 M=1,NQ
         DO 25 I=1,7
   25    F(I,N,M,jset)=F(I,N,M,jset)/(ONED-XX0(N))**N0(I)
   20 CONTINUE
      DO 30 J=1,NTENTH-1
      if(jset.eq.1) XX(J)= LOG10(XX(J))+ONEDO
      DO 30 I=2,6
      DO 30 K=1,NQ
   30 F(I,J,K,jset)= LOG(F(I,J,K,jset))                                 &
     &              *F(I,NTENTH,K,jset)/ LOG(F(I,NTENTH,K,jset))
   50 FORMAT(7F10.5)
      DO 40 I=1,7
      DO 40 M=1,NQ
   40 F(I,NX,M,jset)=ZEROD
      enddo
   10 CONTINUE
!      IF(X.LT.XMIN) X=XMIN
!      IF(X.GT.XMAX) X=XMAX
      QSQ=SCALE**2
!      IF(QSQ.LT.QSQMIN) QSQ=QSQMIN
!      IF(QSQ.GT.QSQMAX) QSQ=QSQMAX
      XXX=X
      IF(X.LT.PONED) XXX= LOG10(X)+ONEDO
      N=0
   70 N=N+1
      IF(XXX.GT.XX(N+1)) GOTO 70
      A=(XXX-XX(N))/(XX(N+1)-XX(N))
      RM= LOG(QSQ/QSQMIN)/ LOG(TWOD)
      B=RM-AINT(RM)
      M=1+  INT(RM)
      DO 60 I=1,7
      G(I)= (ONED-A)*(ONED-B)*F(I,N,M,iset)+(ONED-A)*B*F(I,N,M+1,iset)  &
     &    + A*(ONED-B)*F(I,N+1,M,iset)  + A*B*F(I,N+1,M+1,iset)
      IF(N.GE.NTENTH) GOTO 65
      IF(I.EQ.7.OR.I.EQ.1) GOTO 65
          FAC=(ONED-B)*F(I,NTENTH,M,iset)+B*F(I,NTENTH,M+1,iset)
          G(I)=FAC**(G(I)/FAC)
   65 CONTINUE
      G(I)=G(I)*(ONED-X)**N0(I)
   60 END DO
! UPBAR DISTRIBUTION = D DISTRIBUTION
      UPV=G(2)
      DNV=G(2)
! THIS SEA IS (UBAR+DBAR)/2
      SEA=G(4)
      STR=G(6)
      CHM=G(5)
      GLU=G(3)
      BOT=G(7)
      X=XSAVE
      RETURN
      END


#include "rundeck_opts.h"

      SUBROUTINE SURFCE
!@sum SURFCE calculates the surface fluxes which include
!@+   sensible heat, evaporation, thermal radiation, and momentum
!@+   drag.  It also calculates instantaneous surface temperature,
!@+   surface specific humidity, and surface wind components.
!@auth Nobody will claim responsibilty
      USE CONSTANT, only : grav,rgas,kapa,sday,lhm,lhe,lhs,twopi
     *     ,sha,tf,rhow,rhoi,shv,shw,shi,rvap,stbo,bygrav,by6,byshi
     *     ,byrhoi,deltx,byrt3,teeny
      USE MODEL_COM, only : im,jm,lm,fim,dtsrc,nisurf,u,v,t,p,q
     *     ,idacc,dsig,jday,ndasf,jeq,fland,flice,focean
     *     ,fearth,nday,modrd,itime,jhour,sige,byim,itocean
     *     ,itoice,itlake,itlkice,itlandi,qcheck,UOdrag
      USE GEOM, only : dxyp,imaxj,bydxyp,idjj,idij,rapj,kmaxj,sinip
     *     ,cosip
      USE SOMTQ_COM, only : tmom,qmom,mz,nmom
      USE DYNAMICS, only : pmid,pk,pedn,pek,pdsig,plij,am,byam
      USE RADNCB, only : trhr,fsf,cosz1
#ifdef TRACERS_ON
      USE TRACER_COM, only : ntm,itime_tr0,needtrs,trm,trmom,ntsurfsrc
#ifdef TRACERS_WATER
     *     ,nWATER,nGAS,nPART,tr_wd_TYPE,trname,trw0
#endif
#endif
C**** Interface to PBL
      USE SOCPBL, only : zgs,ZS1,TGV,TKV,QG_SAT,HEMI,DTSURF,POLE
     &     ,US,VS,WS,WSM,WSH,TSV,QSRF,PSI,DBL,KHS,KQS !,PPBL ! ,KMS
     &     ,UG,VG,WG,ZMIX
      USE PBLCOM, only : ipbl,cmgs,chgs,cqgs,tsavg,dclev
      USE PBL_DRV, only : pbl,evap_max,fr_sat,uocean,vocean
#ifdef TRACERS_ON
     *     ,trtop,trs,trsfac,trconstflx,ntx,ntix
#ifdef TRACERS_WATER
     *     ,tr_evap_max
#endif
#endif
      USE DAGCOM, only : oa,aij,tdiurn,aj,areg,adiurn,ndiupt,jreg
     *     ,ij_tsli,ij_shdtli,ij_evhdt,ij_trhdt,ij_shdt,ij_trnfp0
     *     ,ij_srtr,ij_neth,ij_ws,ij_ts,ij_us,ij_vs,ij_taus,ij_tauus
     *     ,ij_tauvs,ij_qs,ij_tg1,ij_evap,ij_evapo,ij_tgo,ij_f0oc
     *     ,ij_f0oi,ij_evapi,ij_f0li,ij_evapli,j_evap,j_evhdt
     *     ,j_tsrf,j_shdt,j_trhdt,j_type,j_tg1,j_tg2,ijdd,idd_spr
     *     ,idd_pt5,idd_pt4,idd_pt3,idd_pt2,idd_pt1,idd_ts,idd_tg1
     *     ,idd_q5,idd_q4,idd_q3,idd_q2,idd_q1,idd_qs,idd_qg,idd_swg
     *     ,idd_lwg,idd_sh,idd_lh,idd_hz0,idd_ug,idd_vg,idd_wg,idd_us
     *     ,idd_vs,idd_ws,idd_cia,idd_cm,idd_ch,idd_cq,idd_eds,idd_dbl
     *     ,idd_ev,idd_ldc,idd_dcf
      USE LANDICE, only : hc2li,z1e,z2li,hc1li
      USE LANDICE_COM, only : snowli
      USE SEAICE, only : xsi,z1i,ace1i,hc1i,alami,byrli,byrls,
     *     solar_ice_frac,tfrez
      USE SEAICE_COM, only : rsi,msi,snowi,flag_dsws
      USE LAKES_COM, only : mwl,mldlk,gml,flake
      USE LAKES, only : minmld
      USE FLUXES, only : dth1,dq1,e0,e1,evapor,runoe,erunoe,sss
     *     ,solar,dmua,dmva,gtemp,nstype,uflux1,vflux1,tflux1,qflux1
     *     ,uosurf,vosurf,uisurf,visurf
#ifdef TRACERS_ON
     *     ,trsrfflx,trsource
#ifdef TRACERS_WATER
     *     ,trevapor,trunoe,gtracer
#endif
      USE TRACER_DIAG_COM, only : taijn,tij_surf
#ifdef TRACERS_WATER
     *     ,tij_evap,tij_grnd,tajls,jls_source
#endif
#endif
      USE SOIL_DRV, only: earth
      IMPLICIT NONE

      INTEGER I,J,K,KR,JR,NS,NSTEPS,MODDSF,MODDD,ITYPE,IH,IDTYPE,IM1
      REAL*8 PLAND,PLICE,POICE,POCEAN,PIJ,PS,P1K,PGK,PKDN
     *     ,BETA,ELHX,ACE2,CDTERM,CDENOM,dF1dTG,HCG1,HCG2,EVHDT,F1DT
     *     ,CM,CH,CQ,DHGS,DQGS,DGS,BETAUP,EVHEAT,F0,F1,DSHDTG,DQGDTG
     *     ,DEVDTG,DTRDTG,DF0DTG,DFDTG,DTG,dSNdTG,dEVdQS,HSDEN,HSCON
     *     ,HSMUL,dHS,dQS,dT2,dTS,DQ1X,EVHDT0,EVAP,F0DT,FTEVAP,PWATER
     *     ,PSK,Q1,THV1,PTYPE,TG1,SRHEAT,SNOW,TG2
     *     ,SHDT,TRHDT,TG,TS,RHOSRF,RCDMWS,RCDHWS,RCDQWS,SHEAT,TRHEAT
     *     ,QSDEN,QSCON,QSMUL,T2DEN,T2CON,T2MUL,TGDEN,FQEVAP
     *     ,Z1BY6L,QZ1,EVAPLIM,F2,FSRI(2),HTLIM

      REAL*8 MSUM, MA1, MSI1
      REAL*8, DIMENSION(NSTYPE,IM,JM) :: TGRND,TGRN2
      REAL*8, PARAMETER :: qmin=1.d-12
      REAL*8, PARAMETER :: S1BYG1 = BYRT3,
     *     Z1IBYL=Z1I/ALAMI, Z2LI3L=Z2LI/(3.*ALAMI), Z1LIBYL=Z1E/ALAMI
      REAL*8 QSAT,DQSATDT
      REAL*8 AREGIJ(7,3,IM,JM)
c
#ifdef TRACERS_ON
      real*8 rhosrf0, totflux
      integer n,nx,nsrc
#ifdef TRACERS_WATER
      real*8, dimension(ntm) :: tevaplim,trgrnd
      real*8  TEV,dTEVdTQS,tevap,dTQS,TDP,TDT1
#ifdef TRACERS_SPECIAL_O18
     *     ,FRACVL,FRACVS,FRACLK,frac
#endif
#endif
#endif

      NSTEPS=NIsurf*ITime
      DTSURF=DTsrc/NIsurf
      IH=JHOUR+1

C**** ZERO OUT ENERGY AND EVAPORATION FOR GROUND AND INITIALIZE TGRND
      DO J=1,JM
      DO I=1,IM
        TGRND(2,I,J)=GTEMP(1,2,I,J)
        TGRND(3,I,J)=GTEMP(1,3,I,J)
C       TGRND(4,I,J)=GTEMP(1,4,I,J)
        TGRN2(2,I,J)=GTEMP(2,2,I,J)
        TGRN2(3,I,J)=GTEMP(2,3,I,J)
      END DO
      END DO

C**** Zero out fluxes summed over type and surface time step
      E0=0. ; E1=0. ; EVAPOR=0. ; RUNOE=0. ; ERUNOE=0.
      DMUA=0. ; DMVA=0. ; SOLAR=0.
      AREGIJ = 0.
#ifdef TRACERS_WATER
      TREVAPOR = 0. ; TRUNOE = 0.
#endif

C****
C**** OUTSIDE LOOP OVER TIME STEPS, EXECUTED NIsurf TIMES EVERY HOUR
C****
      DO NS=1,NIsurf
         MODDSF=MOD(NSTEPS+NS-1,NDASF*NIsurf+1)
         IF(MODDSF.EQ.0) IDACC(3)=IDACC(3)+1
         MODDD=MOD(1+ITime/NDAY+NS,NIsurf)   ! 1+ not really needed ??
C**** ZERO OUT FLUXES ACCUMULATED OVER SURFACE TYPES
         DTH1=0. ;  DQ1 =0. ;  uflux1=0. ; vflux1=0.
#ifdef TRACERS_WATER
         trsrfflx = 0.
#endif

      call loadbl
C****
C**** OUTSIDE LOOP OVER J AND I, EXECUTED ONCE FOR EACH GRID POINT
C****
!$OMP   PARALLEL DO PRIVATE (ACE2, BETA,BETAUP,   CM,CH,CQ,
!$OMP*  CDTERM,CDENOM, DGS,DSHDTG,DQGDTG,DEVDTG,DTRDTG,
!$OMP*  DF0DTG,DFDTG,DTG,DQ1X,DF1DTG,DHGS,DQGS,DSNDTG,DEVDQS,
!$OMP*  DHS,DQS,DT2,DTS, EVAP,EVAPLIM,ELHX,EVHDT,EVHEAT,EVHDT0,
!$OMP*  F0DT,F1DT,F0,F1,F2,FSRI, HCG1,HCG2,HSDEN,HSCON,
!$OMP*  HSMUL,HTLIM,I,ITYPE,IDTYPE,IM1, J,K,
!$OMP*  KR, MSUM,MA1,MSI1, PS,P1K,PLAND,PWATER,
!$OMP*  PLICE,PIJ,POICE,POCEAN,PGK,PKDN,PTYPE,PSK, Q1,QSDEN,
!$OMP*  QSCON,QSMUL, RHOSRF,RCDMWS,RCDHWS,RCDQWS, SHEAT,SRHEAT,
!$OMP*  SNOW,SHDT, T2DEN,T2CON,T2MUL,TGDEN,TS,
!$OMP*  THV1,TG,TG1,TG2,TRHDT,TRHEAT,Z1BY6L
#ifdef TRACERS_ON
!$OMP*  ,n,nx,nsrc,rhosrf0,totflux
#ifdef TRACERS_WATER
!$OMP*  ,tevaplim,tevap,trgrnd,TEV,dTEVdTQS,dTQS,TDP,TDT1
#endif
#endif
!$OMP*  )
!$OMP*  SCHEDULE(DYNAMIC,2)
C
      DO J=1,JM
      HEMI=1.
      IF(J.LE.JM/2) HEMI=-1.
      POLE= (J.EQ.1 .or. J.EQ.JM)

      IM1=IM
      DO I=1,IMAXJ(J)

      EVAPLIM = 0. ; HTLIM=0.  ! need initialisation
#ifdef TRACERS_WATER
      tevaplim = 0.
#endif
C****
C**** DETERMINE SURFACE CONDITIONS
C****
      PLAND=FLAND(I,J)
      PWATER=1.-PLAND
      PLICE=FLICE(I,J)
      POICE=RSI(I,J)*PWATER
      POCEAN=PWATER-POICE
      PIJ=P(I,J)
      PS=PEDN(1,I,J)
      PSK=PEK(1,I,J)
      P1K=PK(1,I,J)
      Q1=Q(I,J,1)
      THV1=T(I,J,1)*(1.+Q1*deltx)
CCC   JR=JREG(I,J)
      MA1=AM(1,I,J) !@var MA1 mass of lowest atmospheric layer (kg/m^2)
      MSUM = (PS*100.)/GRAV !@var MSUM total mass of atmosphere (kg/m^2)
      PGK = (PS*100.)**KAPA
      PKDN = (GRAV*(MSUM-MA1*0.25))**KAPA
#ifdef TRACERS_ON
C**** Set up tracers for PBL calculation if required
      nx=0
      do n=1,ntm
        if (itime_tr0(n).le.itime .and. needtrs(n)) then
          nx=nx+1
          ntix(nx) = n
C**** Calculate first layer tracer concentration
          trtop(nx)=trm(i,j,1,n)*byam(1,i,j)*bydxyp(j)
        end if
      end do
      ntx = nx
#endif
C**** QUANTITIES ACCUMULATED HOURLY FOR DIAGDD
         IF(MODDD.EQ.0) THEN
         DO KR=1,NDIUPT
           IF(I.EQ.IJDD(1,KR).AND.J.EQ.IJDD(2,KR)) THEN
             ADIURN(IH,IDD_SPR,KR)=ADIURN(IH,IDD_SPR,KR)+PS
             ADIURN(IH,IDD_PT5,KR)=ADIURN(IH,IDD_PT5,KR)+PSK*T(I,J,5)
             ADIURN(IH,IDD_PT4,KR)=ADIURN(IH,IDD_PT4,KR)+PSK*T(I,J,4)
             ADIURN(IH,IDD_PT3,KR)=ADIURN(IH,IDD_PT3,KR)+PSK*T(I,J,3)
             ADIURN(IH,IDD_PT2,KR)=ADIURN(IH,IDD_PT2,KR)+PSK*T(I,J,2)
             ADIURN(IH,IDD_PT1,KR)=ADIURN(IH,IDD_PT1,KR)+PSK*T(I,J,1)
             ADIURN(IH,IDD_Q5,KR)=ADIURN(IH,IDD_Q5,KR)+Q(I,J,5)
             ADIURN(IH,IDD_Q4,KR)=ADIURN(IH,IDD_Q4,KR)+Q(I,J,4)
             ADIURN(IH,IDD_Q3,KR)=ADIURN(IH,IDD_Q3,KR)+Q(I,J,3)
             ADIURN(IH,IDD_Q2,KR)=ADIURN(IH,IDD_Q2,KR)+Q(I,J,2)
             ADIURN(IH,IDD_Q1,KR)=ADIURN(IH,IDD_Q1,KR)+Q1
           END IF
         END DO
         END IF
C****
      DO ITYPE=1,3       ! no earth type
      ipbl(i,j,itype)=0
!!!      SELECT CASE (ITYPE)
C****
C**** OPEN OCEAN/LAKE
C****
!!!      CASE (1)
      if ( ITYPE == 1 ) then

      PTYPE=POCEAN
      IF (PTYPE.gt.0) THEN
      TG1=GTEMP(1,1,I,J)
      TG2=GTEMP(2,1,I,J)   ! diagnostic only
      IF (FLAKE(I,J).gt.0) THEN
C**** limit evap/cooling if between MINMLD and 40cm, no evap below 40cm
        IF (MWL(I,J).lt.MINMLD*RHOW*FLAKE(I,J)*DXYP(J)) THEN
          EVAPLIM=MAX(0.5*(MWL(I,J)/(FLAKE(I,J)*DXYP(J))-0.4d0*RHOW),
     *         0d0)
        ELSE
          EVAPLIM=MWL(I,J)/(FLAKE(I,J)*DXYP(J))-(0.5*MINMLD+0.2d0)*RHOW
        END IF
#ifdef TRACERS_WATER
C**** limit on tracer evporation from lake
        TEVAPLIM(1:NTX)=EVAPLIM*GTRACER(NTIX(1:NTX),1,I,J)
#endif
        HTLIM = GML(I,J)/(FLAKE(I,J)*DXYP(J)) + 0.5*LHM*EVAPLIM
        IDTYPE=ITLAKE
        uocean = 0. ; vocean = 0. ! no velocities for lakes
      ELSE
        IDTYPE=ITOCEAN
        if (UOdrag.eq.1) then ! use uocean for drag calculation
C**** Convert UOSURF,VOSURF from C grid to A grid
C**** Note that uosurf,vosurf start with j=1, (not j=2 as in atm winds)
          if (pole) then
            uocean = 0. ; vocean = 0.
            do k=1,kmaxj(j)
              uocean = uocean + rapj(k,j)*(uosurf(idij(k,i,j),idjj(k,j)
     *             -1)*cosip(k)-hemi*vosurf(idij(k,i,j),idjj(k,j)-1)
     *             *sinip(k))
              vocean = vocean + rapj(k,j)*(vosurf(idij(k,i,j),idjj(k,j)
     *             -1)*cosip(k)+hemi*uosurf(idij(k,i,j),idjj(k,j)-1)
     *             *sinip(k))
            end do
          else
            uocean = 0.5*(uosurf(i,j)+uosurf(im1,j))
            vocean = 0.5*(vosurf(i,j)+vosurf(i,j-1))
          end if
        else
          uocean=0. ; vocean=0.
        end if
      END IF
      SRHEAT=FSF(ITYPE,I,J)*COSZ1(I,J)
      SOLAR(1,I,J)=SOLAR(1,I,J)+DTSURF*SRHEAT
            OA(I,J,5)=OA(I,J,5)+SRHEAT*DTSURF
      BETA=1.
      ELHX=LHE
      END IF
C****
C**** OCEAN/LAKE ICE
C****
!!!      CASE (2)
      else if ( ITYPE == 2 ) then

      PTYPE=POICE
      IF (PTYPE.gt.0) THEN
      IF (FLAKE(I,J).gt.0) THEN
        IDTYPE=ITLKICE
        uocean = 0. ; vocean = 0. ! no dynamic ice for lakes
      ELSE
        IDTYPE=ITOICE
        if (UOdrag.eq.1) then ! use ice velcoities in drag calculation
C**** Convert UISURF,VISURF from C grid to A grid
C**** Note that uisurf,visurf start with j=1, (not j=2 as in atm winds)
          if (pole) then
            uocean = 0. ; vocean = 0.
            do k=1,kmaxj(j)
              uocean = uocean + rapj(k,j)*(uisurf(idij(k,i,j),idjj(k,j)
     *             -1)*cosip(k)-hemi*visurf(idij(k,i,j),idjj(k,j)-1)
     *             *sinip(k))
              vocean = vocean + rapj(k,j)*(visurf(idij(k,i,j),idjj(k,j)
     *             -1)*cosip(k)+hemi*uisurf(idij(k,i,j),idjj(k,j)-1)
     *             *sinip(k))
            end do
          else
            uocean = 0.5*(uisurf(i,j)+uisurf(im1,j))
            vocean = 0.5*(visurf(i,j)+visurf(i,j-1))
          end if
        else
          uocean = 0. ; vocean =0.
        end if
      END IF
      SNOW=SNOWI(I,J)
      TG1=TGRND(2,I,J)
      TG2=TGRN2(2,I,J)
      MSI1 = SNOW+ACE1I ! snow and first layer ice mass (kg/m^2)
      ACE2=MSI(I,J) ! second (physical) layer ice mass (kg/m^2)
      dF1dTG = 2./(ACE1I*BYRLI+SNOW*BYRLS)
      HCG1 = SHI*XSI(1)*MSI1 ! heat capacity of top ice layer (J/C*m^2)
      HCG2 = SHI*XSI(2)*MSI1 ! heat capacity of second layer ice
      SRHEAT=FSF(ITYPE,I,J)*COSZ1(I,J)
      SOLAR(2,I,J)=SOLAR(2,I,J)+DTSURF*SRHEAT
C**** fraction of solar radiation leaving layer 1 and 2
      IF (SRHEAT.gt.0) THEN ! only bother if there is sun
        call solar_ice_frac(SNOW,ACE2,FLAG_DSWS(I,J),FSRI,2)
      ELSE
        FSRI(1:2) = 0
      END IF
            OA(I,J,12)=OA(I,J,12)+SRHEAT*DTSURF
      BETA=1.
      ELHX=LHS

      END IF
C****
C**** LAND ICE
C****
!!!      CASE (3)
      else if ( ITYPE == 3 ) then

      PTYPE=PLICE
      IF (PTYPE.gt.0) THEN
      IDTYPE=ITLANDI
      SNOW=SNOWLI(I,J)
      TG1=TGRND(3,I,J)
      TG2=GTEMP(2,3,I,J)
      SRHEAT=FSF(ITYPE,I,J)*COSZ1(I,J)
      Z1BY6L=(Z1LIBYL+SNOW*BYRLS)*BY6
      CDTERM=TG2
      CDENOM=1./(2.*Z1BY6L+Z2LI3L)
      HCG1=HC1LI+SNOW*SHI
      BETA=1.
      ELHX=LHS
      uocean = 0. ; vocean = 0. ! no land ice velocity
      END IF
!!!      END SELECT
      endif
C****
      IF (PTYPE.gt.0) THEN
C****
C**** BOUNDARY LAYER INTERACTION
C****
      TKV=THV1*PSK
      ZS1=.5*DSIG(1)*RGAS*BYGRAV*TKV*PIJ/PS
      SHDT=0.
      EVHDT=0.
      TRHDT=0.
      F1DT=0.

      TG=TG1+TF
      QG_SAT=QSAT(TG,ELHX,PS)
      IF (ITYPE.eq.1 .and. focean(i,j).gt.0) QG_SAT=0.98d0*QG_SAT
      TGV=TG*(1.+QG_SAT*deltx)
#ifdef TRACERS_ON
C**** Set up b.c. for tracer PBL calculation if required
      do nx=1,ntx
        n=ntix(nx)
C**** Set surface boundary conditions for tracers depending on whether
C**** they are water or another type of tracer
#ifdef TRACERS_WATER
        tr_evap_max(nx)=1.
C**** The select is used to distinguish water from gases or particle
!!!        select case (tr_wd_TYPE(n))
!!!        case (nWATER)
        if ( tr_wd_TYPE(n) == nWATER ) then
#ifdef TRACERS_SPECIAL_O18
          if (ITYPE.eq.1) then   ! liquid water => fractionation
        trgrnd(nx)=gtracer(n,itype,i,j)*QG_SAT*FRACVL(TG1,trname(n))
          else   ! ice, no fractionation
            trgrnd(nx)=gtracer(n,itype,i,j)*QG_SAT
          end if
#else
            trgrnd(nx)=gtracer(n,itype,i,j)*QG_SAT
#endif
C**** trsfac and trconstflx are multiplied by cq*wsh in PBL
          trsfac(nx)=1.
          trconstflx(nx)=trgrnd(nx)
!!!        case (nGAS, nPART)
        else if ( tr_wd_TYPE(n) == nGAS .or.
     &         tr_wd_TYPE(n) == nPART ) then
#endif
C**** For non-water tracers (i.e. if TRACERS_WATER is not set, or there
C**** is a non-soluble tracer mixed in.)
C**** Calculate trsfac (set to zero for const flux)
          trsfac(nx)=0.
C**** Calculate trconstflx (m/s * conc) (could be dependent on itype)
          rhosrf0=100.*ps/(rgas*tgv) ! estimated surface density
          totflux=0.
          do nsrc=1,ntsurfsrc(n)
            totflux = totflux+trsource(i,j,nsrc,n)
          end do
          trconstflx(nx)=totflux/(dxyp(j)*rhosrf0)
#ifdef TRACERS_WATER
!!!        end select
        endif
#endif
      end do
#endif
C =====================================================================
      fr_sat = 1. ! entire surface is saturated
      evap_max = 1.
      CALL PBL(I,J,ITYPE,PTYPE)
      CM = cmgs(i,j,itype)
      CH = chgs(i,j,itype)
      CQ = cqgs(i,j,itype)
      DHGS=(ZMIX-ZGS)*CH*WSH
      DQGS=(ZMIX-ZGS)*CQ*WSH
      DGS =DQGS
C =====================================================================
      TS=TSV/(1.+QSRF*deltx)
C**** CALCULATE RHOSRF*CM*WS AND RHOSRF*CH*WS
      RHOSRF=100.*PS/(RGAS*TSV)
      RCDMWS=CM*WSM*RHOSRF
      RCDHWS=CH*WSH*RHOSRF
      RCDQWS=CQ*WSH*RHOSRF
C**** CALCULATE FLUXES OF SENSIBLE HEAT, LATENT HEAT, THERMAL
C****   RADIATION, AND CONDUCTION HEAT (WATTS/M**2)
      SHEAT=SHA*RCDHWS*(TS-TG)
      BETAUP = BETA
      IF (QSRF .GT. QG_SAT) BETAUP = 1.
      EVHEAT=(LHE+TG1*SHV)*BETAUP*RCDQWS*(QSRF-QG_SAT)
      TRHEAT=TRHR(0,I,J)-STBO*(TG*TG)*(TG*TG)
C****
!!!      SELECT CASE (ITYPE)

!!!      CASE (1) ! FLUXES USING IMPLICIT TIME STEP FOR OCEAN POINTS
      if ( ITYPE == 1) then
        DSHDTG=-RCDHWS*SHA
        dEVdQS = LHE*RCDQWS
        dHS = -(1.+2.*S1BYG1)*DTSURF*PGK*SHEAT/
     A       ((1.+2.*S1BYG1)*DTSURF*PGK*RCDHWS+MA1*PKDN)
        dTS = -(1.+2.*S1BYG1)*DTSURF*PGK*SHEAT/
     A       (MA1*PKDN*SHA-(1.+2.*S1BYG1)*DTSURF*PGK*DSHDTG)
        dQS = -(1.+2.*S1BYG1)*DTSURF*EVHEAT/
     A       ((1.+2.*S1BYG1)*DTSURF*dEVdQS+MA1*LHE)
        SHDT = DTSURF*(SHEAT-dTS*DSHDTG)
        EVHDT=DTSURF*(EVHEAT+dQS*dEVdQS) ! latent heat flux
        TRHDT=DTSURF*TRHEAT
C****
!!!      CASE (2) ! FLUXES USING IMPLICIT TIME STEP FOR ICE POINTS
      else if ( ITYPE == 2 ) then

! heat flux on first/second/third layers (W/m^2)
        F1 = (TG1-TG2)*dF1dTG + SRHEAT*FSRI(1)
        F2 = SRHEAT*FSRI(2)
        EVHEAT = LHE*RCDQWS*(QSRF-QG_SAT) ! latent heat flux (W/m^2)
        F0=SRHEAT+TRHEAT+SHEAT+EVHEAT
        dSNdTG=-RCDHWS*KHS*SHA/(DHGS+KHS)
        dQGdTG=QG_SAT*DQSATDT(TG,ELHX) ! d(QG)/dTG
        dEVdTG = -dQGdTG*LHE*RCDQWS*KHS/(DGS+KHS) ! d(EVHEAT)/dTG
        dTRdTG = -4*STBO*TG*TG*TG ! d(TRHEAT)/dTG
        dF0dTG = dSNdTG+dEVdTG+dTRdTG ! d(F0)/dTG
C       dSNdHS = RCDHWS ! d(SHEAT)/dHS - kg/(sec*m^2)
        dEVdQS = LHE*RCDQWS     ! d(EVHEAT)/dQS
        HSDEN = -(1.+2.*S1BYG1)*DTSURF*PGK*BETA*dSNdTG+MA1*PKDN*SHA
        HSCON = -(1.+2.*S1BYG1)*DTSURF*PGK*SHEAT/HSDEN ! (J*sec)/kg
        HSMUL=-(1.+2.*S1BYG1)*DTSURF*PGK*BETA*dSNdTG/HSDEN ! J/(kg*degC)
        QSDEN = (1.+2.*S1BYG1)*BETA*DTSURF*dEVdQS+MA1*LHE
        QSCON = -(1.+2.*S1BYG1)*DTSURF*EVHEAT/QSDEN
        QSMUL = -(1.+2.*S1BYG1)*DTSURF*BETA*dEVdTG/QSDEN
        T2DEN = HCG2+BETA*DTSURF*dF1dTG
        T2CON = DTSURF*(F1-F2)/T2DEN
        T2MUL = BETA*DTSURF*dF1dTG/T2DEN
        TGDEN = HCG1-BETA*DTSURF*(dF0dTG-dF1dTG-
     A       HSMUL*dSNdTG+QSMUL*dEVdQS+T2MUL*dF1dTG) ! W/(m^2*degC)
        dTG = DTSURF*(F0-F1+BETA*
     A       (QSCON*dEVdQS-HSCON*dSNdTG+T2CON*dF1dTG))/TGDEN ! degC
        IF (TG1+dTG .GT. 0.) dTG = -TG1
        dHS = HSCON+HSMUL*dTG   ! (J*sec)/kg
        dQS = QSCON+QSMUL*dTG
        dT2 = T2CON+T2MUL*dTG
        SHDT = DTSURF*(SHEAT+BETA*((dTG-dHS)*dSNdTG)) ! sensible
        EVHDT = DTSURF*(EVHEAT+BETA*(dTG*dEVdTG+dQS*dEVdQS)) ! latent
        TRHDT = DTSURF*(TRHEAT+BETA*dTG*dTRdTG) ! thermal flux (J/m^2)
        F1DT = DTSURF*(F1+BETA*(dTG*dF1dTG-dT2*dF1dTG))
        TG1 = TG1+dTG          ! first layer sea ice temperature (degC)
        TG2 = TG2+dT2          ! second layer sea ice temperature (degC)
        TGRN2(ITYPE,I,J) = TG2
C****
!!!      CASE (3) ! IMPLICIT TIME STEP OVER LANDICE
      else if ( ITYPE == 3 ) then

        F0=SRHEAT+TRHEAT+SHEAT+EVHEAT
        F1=(TG1-CDTERM-F0*Z1BY6L)*CDENOM
        DSHDTG=-RCDHWS*KHS*SHA/(DHGS+KHS)
        DQGDTG=QG_SAT*DQSATDT(TG,ELHX)
        DEVDTG=-RCDQWS*KHS*LHE*BETAUP*DQGDTG/(DQGS+KHS)
        DTRDTG=-4.*STBO*TG*TG*TG
        DF0DTG=DSHDTG+DEVDTG+DTRDTG
        DFDTG=DF0DTG-(1.-DF0DTG*Z1BY6L)*CDENOM
        DTG=(F0-F1)*DTSURF/(HCG1-DTSURF*DFDTG)
        SHDT=DTSURF*(SHEAT+DTG*DSHDTG)
        EVHDT=DTSURF*(EVHEAT+DTG*DEVDTG)
        TRHDT=DTSURF*(TRHEAT+DTG*DTRDTG)
        F1DT=DTSURF*(TG1-CDTERM-(F0+DTG*DFDTG)*Z1BY6L)*CDENOM
        TG1=TG1+DTG

!!!      END SELECT
      endif

C**** CALCULATE EVAPORATION
      DQ1X =EVHDT/((LHE+TG1*SHV)*MA1)
      EVHDT0=EVHDT
C**** Limit evaporation if lake mass is at minimum
      IF (ITYPE.EQ.1 .and. FLAKE(I,J).GT.0 .and.
     *     (EVAPOR(I,J,1)-DQ1X*MA1).gt.EVAPLIM) THEN
        if (QCHECK) WRITE(99,*) "Lake EVAP limited: I,J,EVAP,MWL",I,J
     *     ,EVAPOR(I,J,1)-DQ1X*MA1,MWL(I,J)/(RHOW*FLAKE(I,J)*DXYP(J))
        DQ1X=(EVAPOR(I,J,1)-EVAPLIM)*BYAM(1,I,J)
      ELSEIF (DQ1X.GT.Q1+DQ1(I,J)) THEN
        DQ1X=(Q1+DQ1(I,J))
      ELSE
        GO TO 3720
      END IF
      EVHDT=DQ1X*(LHE+TG1*SHV)*MA1
      IF (ITYPE.NE.1) TG1=TG1+(EVHDT-EVHDT0)/HCG1
 3720 EVAP=-DQ1X*MA1
#ifdef TRACERS_WATER
C****
C**** Calculate Water Tracer Evaporation
C****
      DO NX=1,NTX
        N=NTIX(NX)
        if (tr_wd_TYPE(n).eq.nWATER) THEN
          IF (ITYPE.EQ.1) THEN  ! OCEAN
C**** do calculation implicitly for TQS
#ifdef TRACERS_SPECIAL_O18
            TEV=-RCDQWS*(trs(nx)-trgrnd(nx))*FRACLK(WSM,trname(n))
            dTEVdTQS =-RCDQWS*FRACLK(WSM,trname(n))
#else
            TEV=-RCDQWS*(trs(nx)-trgrnd(nx))
            dTEVdTQS =-RCDQWS
#endif
            dTQS = -(1.+2.*S1BYG1)*DTSURF*TEV/
     *           ((1.+2.*S1BYG1)*DTSURF*dTEVdTQS-MA1)
            TEVAP=DTSURF*(TEV+dTQS*dTEVdTQS)
          ELSE                  ! ICE AND LAND ICE
C**** tracer flux is set by source tracer concentration
            IF (EVAP.GE.0) THEN ! EVAPORATION
              TEVAP=EVAP*trgrnd(nx)/QG_SAT
            ELSE                ! DEW (fractionates)
#ifdef TRACERS_SPECIAL_O18
              IF (TG1.gt.0) THEN
                frac=FRACVL(TG1,trname(n))
              ELSE
                frac=FRACVS(TG1,trname(n))
              END IF
              TEVAP=EVAP*trs(nx)/(QSRF*frac+teeny)
#else
              TEVAP=EVAP*trs(nx)/(QSRF+teeny)
#endif
            END IF
          END IF
C**** Limit evaporation if lake mass is at minimum
          IF (ITYPE.EQ.1 .and. FLAKE(I,J).GT.0 .and.
     *         (TREVAPOR(n,1,I,J)+TEVAP.gt.TEVAPLIM(NX))) THEN
            IF (QCHECK) WRITE(99,*) "Lake TEVAP limited: I,J,TEVAP,TMWL"
     *           ,N,TREVAPOR(n,1,I,J)+TEVAP,TEVAPLIM(NX)
            TEVAP= TEVAPLIM(NX)-TREVAPOR(n,1,I,J)
          END IF
          TDP = TEVAP*DXYP(J)*ptype
          TDT1 = trsrfflx(I,J,n)*DTSURF
          IF (TRM(I,J,1,n)+TDT1+TDP.lt.0..and.tdp.lt.0) THEN
            IF (QCHECK) WRITE(99,*) "LIMITING TRDEW",I,J,N,TDP,TRM(I,J,1
     *           ,n),TDT1
            TEVAP = -(TRM(I,J,1,n)+TDT1)/(DXYP(J)*ptype)
            trsrfflx(I,J,n)= - TRM(I,J,1,n)/DTSURF
          ELSE
            trsrfflx(I,J,n)=trsrfflx(I,J,n)+TDP/DTSURF
          END IF
          TREVAPOR(n,ITYPE,I,J)=TREVAPOR(n,ITYPE,I,J)+TEVAP
        END IF
      END DO
#endif
C**** ACCUMULATE SURFACE FLUXES AND PROGNOSTIC AND DIAGNOSTIC QUANTITIES
      F0DT=DTSURF*SRHEAT+TRHDT+SHDT+EVHDT
C**** Limit heat fluxes out of lakes if near minimum depth
      IF (ITYPE.eq.1 .and. FLAKE(I,J).gt.0 .and.
     *     E0(I,J,1)+F0DT+HTLIM.lt.0) THEN
        if (QCHECK) write(6,*) "Limiting heat flux from lake",i,j,SHDT
     *       ,F0DT,E0(I,J,1),DTSURF*SRHEAT,TRHDT,EVHDT,HTLIM
        SHDT = -(HTLIM+E0(I,J,1)+DTSURF*SRHEAT+TRHDT+EVHDT)
        F0DT = -E0(I,J,1)-HTLIM
        if (QCHECK) write(6,*) "New SHDT,F0DT",i,j,SHDT,F0DT
      END IF
      E0(I,J,ITYPE)=E0(I,J,ITYPE)+F0DT
      E1(I,J,ITYPE)=E1(I,J,ITYPE)+F1DT
      EVAPOR(I,J,ITYPE)=EVAPOR(I,J,ITYPE)+EVAP
      TGRND(ITYPE,I,J)=TG1
      DTH1(I,J)=DTH1(I,J)-SHDT*PTYPE/(SHA*MA1*P1K)
      DQ1(I,J) =DQ1(I,J) -DQ1X*PTYPE
      DMUA(I,J,ITYPE)=DMUA(I,J,ITYPE)+PTYPE*DTSURF*RCDMWS*(US-UOCEAN)
      DMVA(I,J,ITYPE)=DMVA(I,J,ITYPE)+PTYPE*DTSURF*RCDMWS*(VS-VOCEAN)
      uflux1(i,j)=uflux1(i,j)+PTYPE*RCDMWS*(US-UOCEAN)
      vflux1(i,j)=vflux1(i,j)+PTYPE*RCDMWS*(VS-UOCEAN)
C****
C**** ACCUMULATE DIAGNOSTICS FOR EACH SURFACE TIME STEP AND ITYPE
C****
        AJ(J,J_EVAP ,IDTYPE)=AJ(J,J_EVAP ,IDTYPE)+ EVAP*PTYPE
        AJ(J,J_EVHDT,IDTYPE)=AJ(J,J_EVHDT,IDTYPE)+EVHDT*PTYPE
        AJ(J,J_SHDT ,IDTYPE)=AJ(J,J_SHDT ,IDTYPE)+ SHDT*PTYPE
        AJ(J,J_TRHDT,IDTYPE)=AJ(J,J_TRHDT,IDTYPE)+TRHDT*PTYPE
        IF(MODDSF.EQ.0) THEN
          AJ(J,J_TSRF,IDTYPE)=AJ(J,J_TSRF,IDTYPE)+(TS-TF)*PTYPE
          AJ(J,J_TYPE,IDTYPE)=AJ(J,J_TYPE,IDTYPE)+        PTYPE
          AJ(J,J_TG1 ,IDTYPE)=AJ(J,J_TG1 ,IDTYPE)+    TG1*PTYPE
          AJ(J,J_TG2 ,IDTYPE)=AJ(J,J_TG2 ,IDTYPE)+    TG2*PTYPE
        END IF
C**** QUANTITIES ACCUMULATED FOR REGIONS IN DIAGJ
CCC     AREG(JR,J_TRHDT)=AREG(JR,J_TRHDT)+TRHDT*PTYPE*DXYP(J)
CCC     AREG(JR,J_SHDT )=AREG(JR,J_SHDT )+SHDT *PTYPE*DXYP(J)
CCC     AREG(JR,J_EVHDT)=AREG(JR,J_EVHDT)+EVHDT*PTYPE*DXYP(J)
CCC     AREG(JR,J_EVAP )=AREG(JR,J_EVAP )+EVAP *PTYPE*DXYP(J)
CCC     IF(MODDSF.EQ.0)
CCC  *       AREG(JR,J_TSRF)=AREG(JR,J_TSRF)+(TS-TF)*PTYPE*DXYP(J)
        AREGIJ(1,ITYPE,I,J)=TRHDT*PTYPE*DXYP(J)
        AREGIJ(2,ITYPE,I,J)=SHDT *PTYPE*DXYP(J)
        AREGIJ(3,ITYPE,I,J)=EVHDT*PTYPE*DXYP(J)
        AREGIJ(4,ITYPE,I,J)=EVAP *PTYPE*DXYP(J)
        IF(MODDSF.EQ.0) THEN
          AREGIJ(5,ITYPE,I,J)=(TS-TF)*PTYPE*DXYP(J)
          AREGIJ(6,ITYPE,I,J)=    TG1*PTYPE*DXYP(J)
          AREGIJ(7,ITYPE,I,J)=    TG2*PTYPE*DXYP(J)
        END IF
C
C**** QUANTITIES ACCUMULATED FOR LATITUDE-LONGITUDE MAPS IN DIAGIJ
        AIJ(I,J,IJ_SHDT)=AIJ(I,J,IJ_SHDT)+SHDT*PTYPE
        IF(MODRD.EQ.0) AIJ(I,J,IJ_TRNFP0)=AIJ(I,J,IJ_TRNFP0)+TRHDT
     *       *PTYPE/DTSRC
        AIJ(I,J,IJ_SRTR)=AIJ(I,J,IJ_SRTR)+(SRHEAT*DTSURF+TRHDT)*PTYPE
        AIJ(I,J,IJ_NETH)=AIJ(I,J,IJ_NETH)+(SRHEAT*DTSURF+TRHDT+SHDT
     *       +EVHDT)*PTYPE
        AIJ(I,J,IJ_EVAP)=AIJ(I,J,IJ_EVAP)+EVAP*PTYPE
        IF(MODDSF.EQ.0) THEN
          AIJ(I,J,IJ_WS)=AIJ(I,J,IJ_WS)+WS*PTYPE
          AIJ(I,J,IJ_TS)=AIJ(I,J,IJ_TS)+(TS-TF)*PTYPE
          AIJ(I,J,IJ_US)=AIJ(I,J,IJ_US)+US*PTYPE
          AIJ(I,J,IJ_VS)=AIJ(I,J,IJ_VS)+VS*PTYPE
          AIJ(I,J,IJ_TAUS)=AIJ(I,J,IJ_TAUS)+RCDMWS*WSM*PTYPE
          AIJ(I,J,IJ_TAUUS)=AIJ(I,J,IJ_TAUUS)+RCDMWS*(US-UOCEAN)*PTYPE
          AIJ(I,J,IJ_TAUVS)=AIJ(I,J,IJ_TAUVS)+RCDMWS*(VS-VOCEAN)*PTYPE
          AIJ(I,J,IJ_QS)=AIJ(I,J,IJ_QS)+QSRF*PTYPE
          AIJ(I,J,IJ_TG1)=AIJ(I,J,IJ_TG1)+TG1*PTYPE
        END IF
C**** QUANTITIES ACCUMULATED HOURLY FOR DIAGDD
        IF(MODDD.EQ.0) THEN
          DO KR=1,NDIUPT
            IF(I.EQ.IJDD(1,KR).AND.J.EQ.IJDD(2,KR)) THEN
              ADIURN(IH,IDD_TS,KR)=ADIURN(IH,IDD_TS,KR)+TS*PTYPE
              ADIURN(IH,IDD_TG1,KR)=ADIURN(IH,IDD_TG1,KR)+(TG1+TF)*PTYPE
              ADIURN(IH,IDD_QS,KR)=ADIURN(IH,IDD_QS,KR)+QSRF*PTYPE
              ADIURN(IH,IDD_QG,KR)=ADIURN(IH,IDD_QG,KR)+QG_SAT*PTYPE
              ADIURN(IH,IDD_SWG,KR)=ADIURN(IH,IDD_SWG,KR)+SRHEAT*DTSURF
     *             *PTYPE
              ADIURN(IH,IDD_LWG,KR)=ADIURN(IH,IDD_LWG,KR)+TRHDT*PTYPE
              ADIURN(IH,IDD_SH,KR)=ADIURN(IH,IDD_SH,KR)+SHDT*PTYPE
              ADIURN(IH,IDD_LH,KR)=ADIURN(IH,IDD_LH,KR)+EVHDT*PTYPE
              ADIURN(IH,IDD_HZ0,KR)=ADIURN(IH,IDD_HZ0,KR)
     *             +(SRHEAT*DTSURF+TRHDT+SHDT+EVHDT)*PTYPE
              ADIURN(IH,IDD_UG,KR)=ADIURN(IH,IDD_UG,KR)+UG*PTYPE
              ADIURN(IH,IDD_VG,KR)=ADIURN(IH,IDD_VG,KR)+VG*PTYPE
              ADIURN(IH,IDD_WG,KR)=ADIURN(IH,IDD_WG,KR)+WG*PTYPE
              ADIURN(IH,IDD_US,KR)=ADIURN(IH,IDD_US,KR)+US*PTYPE
              ADIURN(IH,IDD_VS,KR)=ADIURN(IH,IDD_VS,KR)+VS*PTYPE
              ADIURN(IH,IDD_WS,KR)=ADIURN(IH,IDD_WS,KR)+WS*PTYPE
              ADIURN(IH,IDD_CIA,KR)=ADIURN(IH,IDD_CIA,KR)+PSI*PTYPE
              ADIURN(IH,IDD_CM,KR)=ADIURN(IH,IDD_CM,KR)+CM*PTYPE
              ADIURN(IH,IDD_CH,KR)=ADIURN(IH,IDD_CH,KR)+CH*PTYPE
              ADIURN(IH,IDD_CQ,KR)=ADIURN(IH,IDD_CQ,KR)+CQ*PTYPE
              ADIURN(IH,IDD_EDS,KR)=ADIURN(IH,IDD_EDS,KR)+KHS*PTYPE
              ADIURN(IH,IDD_DBL,KR)=ADIURN(IH,IDD_DBL,KR)+DBL*PTYPE
              ADIURN(IH,IDD_EV,KR)=ADIURN(IH,IDD_EV,KR)+EVAP*PTYPE
            END IF
          END DO
        END IF
C****
#ifdef TRACERS_ON
C**** Save surface tracer concentration whether calculated or not
      nx=0
      do n=1,ntm
        if (itime_tr0(n).le.itime) then
          if (needtrs(n)) then
            nx=nx+1
            taijn(i,j,tij_surf,n) = taijn(i,j,tij_surf,n)+trs(nx)*ptype
          else
            taijn(i,j,tij_surf,n) = taijn(i,j,tij_surf,n)
     *           +max((trm(i,j,1,n)-trmom(mz,i,j,1,n))*byam(1,i,j)
     *           *bydxyp(j),0d0)*ptype
          end if
#ifdef TRACERS_WATER
          taijn(i,j,tij_evap,n)=taijn(i,j,tij_evap,n)+
     *         trevapor(n,itype,i,j)*ptype
          taijn(i,j,tij_grnd,n)=taijn(i,j,tij_grnd,n)+
     *         gtracer(n,itype,i,j)*ptype/nisurf
          tajls(j,1,jls_source(1,n))=tajls(j,1,jls_source(1,n))
     *         +trevapor(n,itype,i,j)*ptype
          if (focean(i,j).gt.0) tajls(j,1,jls_source(2,n))=tajls(j,1
     *         ,jls_source(2,n))+trevapor(n,itype,i,j)*ptype
#endif
        end if
      end do
#endif
C****
C**** SAVE SOME TYPE DEPENDENT FLUXES/DIAGNOSTICS
C****
!!!      SELECT CASE (ITYPE)
!!!      CASE (1)  ! ocean
      if ( ITYPE == 1 ) then
        OA(I,J,6)=OA(I,J,6)+TRHDT
        OA(I,J,7)=OA(I,J,7)+SHDT
        OA(I,J,8)=OA(I,J,8)+EVHDT
        IF (MODDSF.eq.0) AIJ(I,J,IJ_TGO)=AIJ(I,J,IJ_TGO)+TG1
        AIJ(I,J,IJ_EVAPO)=AIJ(I,J,IJ_EVAPO)+EVAP*PTYPE
        IF (FOCEAN(I,J).gt.0) AIJ(I,J,IJ_F0OC)=AIJ(I,J,IJ_F0OC) +F0DT
     *       *PTYPE
C****
!!!      CASE (2)  ! seaice
      else if ( ITYPE == 2 ) then
        IF (TG1.GT.TDIURN(I,J,7)) TDIURN(I,J,7) = TG1
        OA(I,J,9)=OA(I,J,9)+TRHDT
        OA(I,J,10)=OA(I,J,10)+SHDT
        OA(I,J,11)=OA(I,J,11)+EVHDT
        AIJ(I,J,IJ_F0OI) =AIJ(I,J,IJ_F0OI) +F0DT*PTYPE
        AIJ(I,J,IJ_EVAPI)=AIJ(I,J,IJ_EVAPI)+EVAP*PTYPE
C****
!!!      CASE (3) ! land ice
      else if ( ITYPE == 3 ) then
        IF (TG1.GT.TDIURN(I,J,8)) TDIURN(I,J,8) = TG1
        IF (MODDSF.eq.0) AIJ(I,J,IJ_TSLI)=AIJ(I,J,IJ_TSLI)+(TS-TF)
        AIJ(I,J,IJ_SHDTLI)=AIJ(I,J,IJ_SHDTLI)+SHDT
        AIJ(I,J,IJ_EVHDT)=AIJ(I,J,IJ_EVHDT)+EVHDT
        AIJ(I,J,IJ_TRHDT)=AIJ(I,J,IJ_TRHDT)+TRHDT
        AIJ(I,J,IJ_F0LI)=AIJ(I,J,IJ_F0LI)+F0DT
        AIJ(I,J,IJ_EVAPLI)=AIJ(I,J,IJ_EVAPLI)+EVAP
C****
!!!      END SELECT
      endif
C****
      END IF
      END DO   ! end of itype loop
      IM1=I
      END DO   ! end of I loop

      END DO   ! end of J loop
!$OMP  END PARALLEL DO

      DO J=1,JM
      DO I=1,IMAXJ(J)
        JR=JREG(I,J)
        DO K=1,3
          AREG(JR,J_TRHDT)=AREG(JR,J_TRHDT)+AREGIJ(1,K,I,J)
          AREG(JR,J_SHDT )=AREG(JR,J_SHDT )+AREGIJ(2,K,I,J)
          AREG(JR,J_EVHDT)=AREG(JR,J_EVHDT)+AREGIJ(3,K,I,J)
          AREG(JR,J_EVAP )=AREG(JR,J_EVAP )+AREGIJ(4,K,I,J)
          IF(MODDSF.EQ.0) THEN
            AREG(JR,J_TSRF )=AREG(JR,J_TSRF )+AREGIJ(5,K,I,J)
            AREG(JR,J_TG1)=AREG(JR,J_TG1)+AREGIJ(6,K,I,J)
            AREG(JR,J_TG2)=AREG(JR,J_TG2)+AREGIJ(7,K,I,J)
          END IF
        END DO
      END DO
      END DO
C****
C**** EARTH
C****
      CALL EARTH(NS,MODDSF,MODDD)
C****
C**** UPDATE FIRST LAYER QUANTITIES
C****
!$OMP  PARALLEL DO PRIVATE (I,J,FTEVAP,FQEVAP,P1K)
!$OMP*          SCHEDULE(DYNAMIC,2)
      DO J=1,JM
      DO I=1,IMAXJ(J)
        FTEVAP=0
        IF (DTH1(I,J)*T(I,J,1).lt.0) FTEVAP=-DTH1(I,J)/T(I,J,1)
        FQEVAP=0
        IF (DQ1(I,J).lt.0.and.Q(I,J,1).gt.0) FQEVAP=-DQ1(I,J)/Q(I,J,1)
! Z-moments should be set from PBL
        TMOM(:,I,J,1) = TMOM(:,I,J,1)*(1.-FTEVAP)
        QMOM(:,I,J,1) = QMOM(:,I,J,1)*(1.-FQEVAP)
        IF ( Q(I,J,1)+DQ1(I,J) .LT. qmin ) THEN
          WRITE(99,*)
     &         ITime,'I,J:',I,J,' Q1:',Q(I,J,1)+DQ1(I,J),'->',qmin
          dq1(i,j)=qmin-q(i,j,1)
          QMOM(:,I,J,1)=0.
        ENDIF
c****   retrieve fluxes
        P1K=PK(1,I,J)
        tflux1(i,j)=dth1(i,j)*(-AM(1,I,J)*P1K)/(dtsurf)
        qflux1(i,j)=dq1(i,j)*(-AM(1,I,J))/(dtsurf)
C**** Diurnal cycle of temperature diagnostics
        tdiurn(i,j,5)=tdiurn(i,j,5)+(tsavg(i,j)-tf)
        if(tsavg(i,j).gt.tdiurn(i,j,6)) tdiurn(i,j,6)=tsavg(i,j)
        if(tsavg(i,j).lt.tdiurn(i,j,9)) tdiurn(i,j,9)=tsavg(i,j)
      END DO
      END DO
!$OMP  END PARALLEL DO
#ifdef TRACERS_ON
C****
C**** Apply tracer surface sources and sinks
C****
      call apply_tracer_2Dsource(dtsurf)
#endif
c****
c**** apply surface fluxes to the first layer of the atmosphere
c****  (replaced with dummy subroutine when ATURB is used)
c****
      call apply_fluxes_to_atm(dtsurf)

C**** Call dry convection or aturb depending on rundeck
      CALL ATM_DIFFUS(1,1,dtsurf)
C****
C**** ACCUMULATE SOME ADDITIONAL BOUNDARY LAYER DIAGNOSTICS
C****
      IF(MODDD.EQ.0) THEN
        DO KR=1,NDIUPT
C**** CHECK IF DRY CONV HAS HAPPENED FOR THIS DIAGNOSTIC
          IF(DCLEV(IJDD(1,KR),IJDD(2,KR)).GT.1.) THEN
            ADIURN(IH,IDD_DCF,KR)=ADIURN(IH,IDD_DCF,KR)+1.
            ADIURN(IH,IDD_LDC,KR)=ADIURN(IH,IDD_LDC,KR)
     *           +DCLEV(IJDD(1,KR),IJDD(2,KR))
          END IF
        END DO
      END IF
C****
      END DO   ! end of surface time step
      RETURN
C****
      END SUBROUTINE SURFCE