! source from http://www-surf.larc.nasa.gov/surf/pages/ftp-page.html
! translated with vf90 from fortran90 to fortran77
! edited all function names:
!   1st all function names in lowercase
!     (c is case sensitive, fortran is not)
!   2nd removed all underscores "_" from function names
!     (as compiles adds an additional _
!      if there is an _ in the function name)

      BLOCK DATA spectral_dat_bd
      INCLUDE 'IGBP_spectral_albedo.inc'

      DATA SPECALBIGBP/ 0.032, 0.032, 0.032, 0.032, 0.032, 0.032, 0.032
     1   , 0.032, 0.046, 0.046, 0.235, 0.096, 0.038, 0.038, 0.038, 0.044
     2   , 0.044, 0.044, 0.044, 0.044, 0.044, 0.044, 0.044, 0.044, 0.044
     3   , 0.234, 0.193, 0.112, 0.112, 0.112, 0.032, 0.032, 0.032, 0.032
     4   , 0.032, 0.032, 0.032, 0.032, 0.046, 0.046, 0.235, 0.096, 0.038
     5   , 0.038, 0.038, 0.034, 0.034, 0.034, 0.034, 0.034, 0.034, 0.034
     6   , 0.034, 0.066, 0.067, 0.312, 0.276, 0.160, 0.160, 0.160, 0.033
     7   , 0.033, 0.033, 0.033, 0.033, 0.033, 0.033, 0.033, 0.056, 0.057
     8   , 0.274, 0.186, 0.099, 0.099, 0.099, 0.010, 0.010, 0.010, 0.015
     9   , 0.017, 0.020, 0.036, 0.045, 0.154, 0.156, 0.350, 0.239, 0.101
     .   , 0.101, 0.101, 0.095, 0.095, 0.095, 0.095, 0.095, 0.095, 0.098
     1   , 0.104, 0.122, 0.157, 0.231, 0.330, 0.311, 0.150, 0.150, 0.020
     2   , 0.020, 0.020, 0.023, 0.024, 0.026, 0.035, 0.041, 0.102, 0.104
     3   , 0.366, 0.291, 0.151, 0.107, 0.107, 0.010, 0.010, 0.010, 0.015
     4   , 0.017, 0.020, 0.036, 0.045, 0.126, 0.129, 0.402, 0.301, 0.145
     5   , 0.071, 0.071, 0.010, 0.010, 0.010, 0.015, 0.017, 0.020, 0.036
     6   , 0.045, 0.126, 0.129, 0.402, 0.301, 0.145, 0.071, 0.071, 0.039
     7   , 0.039, 0.039, 0.039, 0.039, 0.039, 0.039, 0.039, 0.051, 0.071
     8   , 0.164, 0.100, 0.056, 0.056, 0.056, 0.010, 0.010, 0.010, 0.015
     9   , 0.017, 0.020, 0.036, 0.045, 0.115, 0.099, 0.442, 0.271, 0.122
     .   , 0.059, 0.059, 0.052, 0.052, 0.052, 0.052, 0.052, 0.052, 0.052
     1   , 0.066, 0.104, 0.114, 0.304, 0.258, 0.258, 0.258, 0.258, 0.010
     2   , 0.010, 0.010, 0.015, 0.017, 0.020, 0.036, 0.045, 0.090, 0.083
     3   , 0.377, 0.273, 0.141, 0.110, 0.110, 0.910, 0.910, 0.910, 0.916
     4   , 0.921, 0.931, 0.947, 0.964, 0.953, 0.920, 0.635, 0.013, 0.006
     5   , 0.009, 0.014, 0.144, 0.144, 0.144, 0.144, 0.144, 0.144, 0.144
     6   , 0.179, 0.263, 0.331, 0.405, 0.390, 0.390, 0.390, 0.390, 0.066
     7   , 0.066, 0.066, 0.070, 0.073, 0.082, 0.094, 0.091, 0.078, 0.072
     8   , 0.066, 0.062, 0.055, 0.044, 0.069, 0.010, 0.010, 0.010, 0.015
     9   , 0.017, 0.020, 0.036, 0.045, 0.113, 0.115, 0.247, 0.265, 0.265
     .   , 0.265, 0.265, 0.979, 0.979, 0.979, 0.980, 0.982, 0.984, 0.988
     1   , 0.992, 0.989, 0.982, 0.902, 0.143, 0.168, 0.019, 0.015, 0.778
     2   , 0.778, 0.778, 0.778, 0.778, 0.778, 0.778, 0.778, 0.778, 0.752
     3   , 0.393, 0.055, 0.054, 0.036, 0.036/
C                                                !(20) SEA ICE
      DATA EMISSTBL/ 0.989, 0.989, 0.990, 0.991, 0.991, 0.990, 0.990,
     1   0.995, 1.000, 1.000, 1.000, 1.000, 0.989, 0.989, 0.990, 0.991,
     2   0.991, 0.990, 0.990, 0.995, 1.000, 1.000, 1.000, 1.000, 0.985,
     3   0.986, 0.984, 0.983, 0.979, 0.980, 0.973, 0.987, 1.000, 1.000,
     4   1.000, 1.000, 0.985, 0.986, 0.984, 0.983, 0.979, 0.980, 0.973,
     5   0.987, 1.000, 1.000, 1.000, 1.000, 0.987, 0.987, 0.987, 0.987,
     6   0.985, 0.985, 0.982, 0.991, 1.000, 1.000, 1.000, 1.000, 0.949,
     7   0.970, 0.974, 0.971, 0.947, 0.958, 0.966, 0.975, 0.984, 0.984,
     8   0.984, 0.984, 0.873, 0.934, 0.944, 0.939, 0.873, 0.904, 0.936,
     9   0.942, 0.951, 0.951, 0.951, 0.951, 0.987, 0.990, 0.992, 0.993,
     .   0.983, 0.975, 0.985, 0.993, 1.000, 1.000, 1.000, 1.000, 0.987,
     1   0.990, 0.992, 0.993, 0.983, 0.975, 0.985, 0.993, 1.000, 1.000,
     2   1.000, 1.000, 0.987, 0.990, 0.992, 0.993, 0.983, 0.975, 0.985,
     3   0.993, 1.000, 1.000, 1.000, 1.000, 0.983, 0.987, 0.987, 0.988,
     4   0.983, 0.981, 0.987, 0.982, 0.986, 0.986, 0.986, 0.986, 0.987,
     5   0.990, 0.992, 0.993, 0.983, 0.975, 0.985, 0.993, 1.000, 1.000,
     6   1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000,
     7   1.000, 1.000, 1.000, 1.000, 1.000, 0.987, 0.989, 0.989, 0.990,
     8   0.984, 0.980, 0.983, 0.992, 1.000, 1.000, 1.000, 1.000, 1.000,
     9   1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 0.999, 0.999, 0.999,
     .   0.999, 0.999, 0.835, 0.916, 0.934, 0.923, 0.835, 0.877, 0.921,
     1   0.926, 0.934, 0.934, 0.934, 0.934, 0.979, 0.983, 0.982, 0.982,
     2   0.984, 0.987, 0.989, 0.972, 0.972, 0.972, 0.972, 0.972, 0.947,
     3   0.967, 0.988, 0.979, 0.975, 0.977, 0.992, 0.989, 0.989, 0.989,
     4   0.989, 0.989, 0.988, 0.988, 0.988, 0.988, 0.988, 0.988, 0.988,
     5   0.988, 0.988, 0.988, 0.988, 0.988, 0.979, 0.979, 0.979, 0.979,
     6   0.979, 0.979, 0.979, 0.979, 0.979, 0.979, 0.979, 0.979/
      END
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
C                                                ! O
      SUBROUTINE getemiss(IGBP, EMS12)
C...Translated by Pacific-Sierra Research vf90 Personal 3.4N5 16:25:20 9/11/06
C...Switches:
      INCLUDE 'IGBP_spectral_albedo.inc'
      INTEGER IGBP
      REAL EMS12(12)
      INTEGER J1

      D(1) = 0.40
      D(2) = 0.44
      D(3) = 0.32
      D(4) = 0.39
      D(5) = 0.22
      D(6) = 0.28
      D(7) = 0.40
      D(8) = 0.47
      D(9) = 0.53
      D(10) = 0.53
      D(11) = 0.35
      D(12) = 0.41
      D(13) = 0.10
      D(14) = 0.40
      D(15) = 0.10
      D(16) = 0.40
      D(17) = 0.41
      D(18) = 0.58
      D(19) = 0.10
      D(20) = 0.10
      DO J1 = 1, 12
         EMS12(J1) = EMISSTBL(J1,IGBP)
      END DO
!
!
      END
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
C                                                ! O
      SUBROUTINE landspec(IGBP, U0, WV, SALB15, BBALB)
C...Translated by Pacific-Sierra Research vf90 Personal 3.4N5 16:25:20 9/11/06
C...Switches:
      INCLUDE 'IGBP_spectral_albedo.inc'
      REAL BBALB
      INTEGER IGBP
      REAL SALB15(15)
      REAL U0
      REAL WV
!
      INTEGER I
      REAL WGTS(15)
      REAL ZENADJ
      REAL R1
      INTEGER J2

      D(1) = 0.40
      D(2) = 0.44
      D(3) = 0.32
      D(4) = 0.39
      D(5) = 0.22
      D(6) = 0.28
      D(7) = 0.40
      D(8) = 0.47
      D(9) = 0.53
      D(10) = 0.53
      D(11) = 0.35
      D(12) = 0.41
      D(13) = 0.10
      D(14) = 0.40
      D(15) = 0.10
      D(16) = 0.40
      D(17) = 0.41
      D(18) = 0.58
      D(19) = 0.10
      D(20) = 0.10

      ZENADJ = (1.0 + D(IGBP))/(1.0 + 2.0*D(IGBP)*U0)
      DO J2 = 1, 15
         SALB15(J2) = SPECALBIGBP(J2,IGBP)*ZENADJ
      END DO
      DO J2 = 1, 15
         IF (SALB15(J2) .GT. 1.0) SALB15(J2) = 1.0
      END DO
      DO J2 = 1, 15
         IF (SALB15(J2) .LT. 0.0) SALB15(J2) = 0.0
      END DO
!
      CALL swdnwgts (U0, WV, WGTS) ! O
!
      R1 = 0
      DO J2 = 1, 15
         R1 = R1 + WGTS(J2)*SALB15(J2)
      END DO
      BBALB = R1
!
!
      END
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
C                                                ! O
      SUBROUTINE swdnwgts(CSZ, PW, WGT)
C...Translated by Pacific-Sierra Research vf90 Personal 3.4N5 16:25:20 9/11/06
C...Switches:
      INCLUDE 'IGBP_spectral_albedo.inc'
      REAL WGTS(15,4,3), WGT(15)
      REAL LNPWS(3), CSZS(4)
      REAL YW(2), XW(2), CSZ, PW, LNPW, A1, A2
      INTEGER I, IW, XL(2), YL(2)
      INTEGER J3
      DATA WGTS/ 1.793E-26, 1.427E-28, 4.677E-14, 4.706E-06, 3.297E-03,
     1   1.653E-02, 7.526E-02, 9.746E-02, 1.573E-01, 1.534E-01,
     2   3.855E-01, 7.185E-02, 3.084E-02, 4.141E-03, 4.468E-03,
     3   3.422E-28, 1.070E-30, 1.849E-15, 1.920E-06, 2.667E-03,
     4   1.501E-02, 7.254E-02, 9.664E-02, 1.577E-01, 1.550E-01,
     5   3.894E-01, 7.199E-02, 3.066E-02, 3.910E-03, 4.486E-03,
     6   2.351E-29, 8.316E-32, 1.851E-17, 2.713E-08, 9.317E-04,
     7   9.006E-03, 5.932E-02, 9.118E-02, 1.572E-01, 1.613E-01,
     8   4.096E-01, 7.373E-02, 3.014E-02, 3.123E-03, 4.509E-03,
     9   5.614E-30, 2.067E-32, 4.499E-18, 1.748E-09, 3.743E-05,
     .   1.207E-03, 2.406E-02, 6.307E-02, 1.365E-01, 1.687E-01,
     1   4.834E-01, 8.611E-02, 3.055E-02, 2.080E-03, 4.327E-03,
     2   3.575E-29, 0.000E+00, 6.410E-19, 3.645E-07, 2.449E-03,
     3   1.538E-02, 7.025E-02, 9.050E-02, 1.444E-01, 1.416E-01,
     4   3.973E-01, 8.968E-02, 3.600E-02, 7.953E-03, 4.502E-03,
     5   9.025E-31, 0.000E+00, 6.506E-21, 1.069E-07, 1.945E-03,
     6   1.393E-02, 6.758E-02, 8.945E-02, 1.441E-01, 1.425E-01,
     7   4.026E-01, 8.963E-02, 3.602E-02, 7.771E-03, 4.541E-03,
     8   7.959E-32, 0.000E+00, 2.160E-22, 7.293E-10, 6.241E-04,
     9   8.289E-03, 5.477E-02, 8.329E-02, 1.403E-01, 1.454E-01,
     .   4.285E-01, 9.087E-02, 3.622E-02, 7.051E-03, 4.706E-03,
     1   1.719E-32, 0.000E+00, 5.086E-23, 1.147E-10, 2.030E-05,
     2   1.081E-03, 2.166E-02, 5.544E-02, 1.126E-01, 1.427E-01,
     3   5.142E-01, 1.035E-01, 3.836E-02, 5.457E-03, 5.027E-03,
     4   3.910E-16, 1.975E-27, 9.897E-18, 9.722E-07, 3.687E-03,
     5   1.942E-02, 7.475E-02, 8.861E-02, 1.359E-01, 1.307E-01,
     6   3.785E-01, 1.130E-01, 3.848E-02, 1.268E-02, 4.279E-03,
     7   2.326E-17, 1.286E-29, 1.353E-19, 3.318E-07, 3.150E-03,
     8   1.849E-02, 7.339E-02, 8.814E-02, 1.354E-01, 1.308E-01,
     9   3.817E-01, 1.134E-01, 3.863E-02, 1.253E-02, 4.311E-03,
     .   1.727E-18, 1.177E-30, 3.400E-21, 2.601E-09, 1.469E-03,
     1   1.432E-02, 6.665E-02, 8.549E-02, 1.322E-01, 1.309E-01,
     2   3.974E-01, 1.156E-01, 3.954E-02, 1.206E-02, 4.453E-03,
     3   3.439E-19, 2.483E-31, 7.044E-22, 2.676E-10, 1.108E-04,
     4   4.962E-03, 4.327E-02, 7.201E-02, 1.147E-01, 1.262E-01,
     5   4.537E-01, 1.254E-01, 4.305E-02, 1.170E-02, 4.912E-03/
      DATA LNPWS/ 1.009, -0.830,  - 3.730/
      DATA CSZS/ 1.00000, 0.86603, 0.50000, 0.17365/
      D(1) = 0.40
      D(2) = 0.44
      D(3) = 0.32
      D(4) = 0.39
      D(5) = 0.22
      D(6) = 0.28
      D(7) = 0.40
      D(8) = 0.47
      D(9) = 0.53
      D(10) = 0.53
      D(11) = 0.35
      D(12) = 0.41
      D(13) = 0.10
      D(14) = 0.40
      D(15) = 0.10
      D(16) = 0.40
      D(17) = 0.41
      D(18) = 0.58
      D(19) = 0.10
      D(20) = 0.10
      LNPW = LOG(PW)                             !!

!---
! solar zenith angle, (x) weights
!---

      IF (CSZ.LT.0.0) THEN
         ! OK sun below horizon
         CSZ = 0.0
         RETURN
      ENDIF

      IF (CSZ.LT.0.0 .OR. CSZ.GT.1.0) THEN
         PRINT *, 'bad solar zenith angle - ', CSZ
         RETURN
      ENDIF

      I = 1
    2 CONTINUE
      IF (CSZ .LE. CSZS(I)) THEN
         I = I + 1
         GO TO 2
      ENDIF
      IF (I .LT. 5) THEN
         XL(1) = I - 1
         XL(2) = I
         XW(1) = (CSZS(XL(1))-CSZ)/(CSZS(XL(1))-CSZS(XL(2)))
         XW(2) = 1. - XW(1)
      ELSE IF (I .GT. 4) THEN
         DO J3 = 1, 2
            XL(J3) = 4
         END DO
         XW(1) = 0.0
         XW(2) = 1.0
      ENDIF
!---
! pw, (y) weights
!---
      I = 1
    3 CONTINUE
      IF (LNPW .LE. LNPWS(I)) THEN
         I = I + 1
         GO TO 3
      ENDIF
      IF (I .EQ. 1) THEN
         DO J3 = 1, 2
            YL(J3) = I
         END DO
         YW(1) = 1.0
         YW(2) = 0.0
      ELSE IF (I.GT.1 .AND. I.LT.4) THEN
         YL(1) = I - 1
         YL(2) = I
         YW(1) = (LNPWS(YL(1))-LNPW)/(LNPWS(YL(1))-LNPWS(YL(2)))
         YW(2) = 1. - YW(1)
      ELSE IF (I .GT. 3) THEN
         DO J3 = 1, 2
            YL(J3) = 3
         END DO
         YW(1) = 0.0
         YW(2) = 1.0
      ENDIF

      DO I = 1, 15
         A1 = WGTS(I,XL(1),YL(1))*XW(2) + WGTS(I,XL(2),YL(1))*XW(1)
         A2 = WGTS(I,XL(1),YL(2))*XW(2) + WGTS(I,XL(2),YL(2))*XW(1)
         WGT(I) = A1*YW(2) + A2*YW(1)
      END DO

      END


Subroutine lukfdi(kfl1, kfl2, kfl3, kf)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  kf1a = iabs(kfl1)
  kf2a = iabs(kfl2)
  kfl3 = 0
  kf = 0
  If (kf1a==0) Return
  If (kf2a/=0) Then
    If (kf1a<=10 .And. kf2a<=10 .And. kfl1*kfl2>0) Return
    If (kf1a>10 .And. kf2a>10) Return
    If ((kf1a>10 .Or. kf2a>10) .And. kfl1*kfl2<0) Return
  End If
  If (mstj(15)==1) Then
    ktab1 = -1
    If (kf1a>=1 .And. kf1a<=6) ktab1 = kf1a
    kfl1a = mod(kf1a/1000, 10)
    kfl1b = mod(kf1a/100, 10)
    kfl1s = mod(kf1a, 10)
    If (kfl1a>=1 .And. kfl1a<=4 .And. kfl1b>=1 .And. kfl1b<=4) ktab1 = 6 + kfl1a*(kfl1a-2) + 2*kfl1b + (kfl1s-1)/2
    If (kfl1a>=1 .And. kfl1a<=4 .And. kfl1a==kfl1b) ktab1 = ktab1 - 1
    If (kf1a>=1 .And. kf1a<=6) kfl1a = kf1a
    ktab2 = 0
    If (kf2a/=0) Then
      ktab2 = -1
      If (kf2a>=1 .And. kf2a<=6) ktab2 = kf2a
      kfl2a = mod(kf2a/1000, 10)
      kfl2b = mod(kf2a/100, 10)
      kfl2s = mod(kf2a, 10)
      If (kfl2a>=1 .And. kfl2a<=4 .And. kfl2b>=1 .And. kfl2b<=4) ktab2 = 6 + kfl2a*(kfl2a-2) + 2*kfl2b + (kfl2s-1)/2
      If (kfl2a>=1 .And. kfl2a<=4 .And. kfl2a==kfl2b) ktab2 = ktab2 - 1
    End If
    If (ktab1>=0 .And. ktab2>=0) Goto 140
  End If
  100 par2 = parj(2)
  par3 = parj(3)
  par4 = 3.*parj(4)
  If (mstj(12)>=2) Then
    par3m = sqrt(parj(3))
    par4m = 1./(3.*sqrt(parj(4)))
    pardm = parj(7)/(parj(7)+par3m*parj(6))
    pars0 = parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))
    pars1 = parj(7)*pars0/(2.*par3m) + parj(5)*(parj(6)*(1.+par4m)+par2*par3m*parj(6)*parj(7))
    pars2 = parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)
    parsm = max(pars0, pars1, pars2)
    par4 = par4*(1.+parsm)/(1.+parsm/(3.*par4m))
  End If
  mbary = 0
  kfda = 0
  If (kf1a<=10) Then
    If (kf2a==0 .And. mstj(12)>=1 .And. (1.+parj(1))*rlu(0)>1.) mbary = 1
    If (kf2a>10) mbary = 2
    If (kf2a>10 .And. kf2a<=10000) kfda = kf2a
  Else
    mbary = 2
    If (kf1a<=10000) kfda = kf1a
  End If
  If (kfda/=0 .And. mstj(12)>=2) Then
    kflda = mod(kfda/1000, 10)
    kfldb = mod(kfda/100, 10)
    kflds = mod(kfda, 10)
    wtdq = pars0
    If (max(kflda,kfldb)==3) wtdq = pars1
    If (min(kflda,kfldb)==3) wtdq = pars2
    If (kflds==1) wtdq = wtdq/(3.*par4m)
    If ((1.+wtdq)*rlu(0)>1.) mbary = -1
    If (mbary==-1 .And. kf2a/=0) Return
  End If
  If (mbary<=0) Then
    kfs = isign(1, kfl1)
    If (mbary==0) Then
      If (kf2a==0) kfl3 = isign(1+int((2.+par2)*rlu(0)), -kfl1)
      kfla = max(kf1a, kf2a+iabs(kfl3))
      kflb = min(kf1a, kf2a+iabs(kfl3))
      If (kfla/=kf1a) kfs = -kfs
    Else
      kfl1a = mod(kf1a/1000, 10)
      kfl1b = mod(kf1a/100, 10)
      110 kfl1d = kfl1a + int(rlu(0)+0.5)*(kfl1b-kfl1a)
      kfl1e = kfl1a + kfl1b - kfl1d
      If ((kfl1d==3 .And. rlu(0)>pardm) .Or. (kfl1e==3 .And. rlu(0)<pardm)) Then
        kfl1d = kfl1a + kfl1b - kfl1d
        kfl1e = kfl1a + kfl1b - kfl1e
      End If
      kfl3a = 1 + int((2.+par2*par3m*parj(7))*rlu(0))
      If ((kfl1e/=kfl3a .And. rlu(0)>(1.+par4m)/max(2.,1.+par4m)) .Or. (kfl1e==kfl3a .And. rlu(0)>2./max(2.,1.+par4m))) Goto 110
      kflds = 3
      If (kfl1e/=kfl3a) kflds = 2*int(rlu(0)+1./(1.+par4m)) + 1
      kfl3 = isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+kflds, -kfl1)
      kfla = max(kfl1d, kfl3a)
      kflb = min(kfl1d, kfl3a)
      If (kfla/=kfl1d) kfs = -kfs
    End If
    If (kfla<=2) kmul = int(parj(11)+rlu(0))
    If (kfla==3) kmul = int(parj(12)+rlu(0))
    If (kfla>=4) kmul = int(parj(13)+rlu(0))
    If (kmul==0 .And. parj(14)>0.) Then
      If (rlu(0)<parj(14)) kmul = 2
    Else If (kmul==1 .And. parj(15)+parj(16)+parj(17)>0.) Then
      rmul = rlu(0)
      If (rmul<parj(15)) kmul = 3
      If (kmul==1 .And. rmul<parj(15)+parj(16)) kmul = 4
      If (kmul==1 .And. rmul<parj(15)+parj(16)+parj(17)) kmul = 5
    End If
    kfls = 3
    If (kmul==0 .Or. kmul==3) kfls = 1
    If (kmul==5) kfls = 5
    If (kfla/=kflb) Then
      kf = (100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
    Else
      rmix = rlu(0)
      imix = 2*kfla + 10*kmul
      If (kfla<=3) kf = 110*(1+int(rmix+parf(imix-1))+int(rmix+parf(imix))) + kfls
      If (kfla>=4) kf = 110*kfla + kfls
    End If
    If (kmul==2 .Or. kmul==3) kf = kf + isign(10000, kf)
    If (kmul==4) kf = kf + isign(20000, kf)
  Else
    120 If (kf1a<=10 .And. kf2a==0) Then
      kfla = kf1a
      130 kflb = 1 + int((2.+par2*par3)*rlu(0))
      kflc = 1 + int((2.+par2*par3)*rlu(0))
      kflds = 1
      If (kflb>=kflc) kflds = 3
      If (kflds==1 .And. par4*rlu(0)>1.) Goto 130
      If (kflds==3 .And. par4<rlu(0)) Goto 130
      kfl3 = isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds, kfl1)
    Else If (kf1a<=10) Then
      kfla = kf1a
      kflb = mod(kf2a/1000, 10)
      kflc = mod(kf2a/100, 10)
      kflds = mod(kf2a, 10)
    Else
      If (kf2a==0) kfl3 = isign(1+int((2.+par2)*rlu(0)), kfl1)
      kfla = kf2a + iabs(kfl3)
      kflb = mod(kf1a/1000, 10)
      kflc = mod(kf1a/100, 10)
      kflds = mod(kf1a, 10)
    End If
    kbary = kflds
    If (kflds==3 .And. kflb/=kflc) kbary = 5
    If (kfla/=kflb .And. kfla/=kflc) kbary = kbary + 1
    wt = parf(60+kbary) + parj(18)*parf(70+kbary)
    If (mbary==1 .And. mstj(12)>=2) Then
      wtdq = pars0
      If (max(kflb,kflc)==3) wtdq = pars1
      If (min(kflb,kflc)==3) wtdq = pars2
      If (kflds==1) wtdq = wtdq/(3.*par4m)
      If (kflds==1) wt = wt*(1.+wtdq)/(1.+parsm/(3.*par4m))
      If (kflds==3) wt = wt*(1.+wtdq)/(1.+parsm)
    End If
    If (kf2a==0 .And. wt<rlu(0)) Goto 120
    kfld = max(kfla, kflb, kflc)
    kflf = min(kfla, kflb, kflc)
    kfle = kfla + kflb + kflc - kfld - kflf
    kfls = 2
    If ((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0)>parf(60+kbary)) kfls = 4
    kfll = 0
    If (kfls==2 .And. kfld>kfle .And. kfle>kflf) Then
      If (kflds==1 .And. kfla==kfld) kfll = 1
      If (kflds==1 .And. kfla/=kfld) kfll = int(0.25+rlu(0))
      If (kflds==3 .And. kfla/=kfld) kfll = int(0.75+rlu(0))
    End If
    If (kfll==0) kf = isign(1000*kfld+100*kfle+10*kflf+kfls, kfl1)
    If (kfll==1) kf = isign(1000*kfld+100*kflf+10*kfle+kfls, kfl1)
  End If
  Return
  140 If (ktab2==0 .And. mstj(12)<=0) Then
    kt3l = 1
    kt3u = 6
  Else If (ktab2==0 .And. ktab1>=7 .And. mstj(12)<=1) Then
    kt3l = 1
    kt3u = 6
  Else If (ktab2==0) Then
    kt3l = 1
    kt3u = 22
  Else
    kt3l = ktab2
    kt3u = ktab2
  End If
  rfl = 0.
  Do kts = 0, 2
    Do kt3 = kt3l, kt3u
      rfl = rfl + parf(120+80*ktab1+25*kts+kt3)
    End Do
  End Do
  rfl = rlu(0)*rfl
  Do kts = 0, 2
    ktabs = kts
    Do kt3 = kt3l, kt3u
      ktab3 = kt3
      rfl = rfl - parf(120+80*ktab1+25*kts+kt3)
      If (rfl<=0.) Goto 170
    End Do
  End Do
  170 Continue
  If (ktab3<=6) Then
    kfl3a = ktab3
    kfl3b = 0
    kfl3 = isign(kfl3a, kfl1*(2*ktab1-13))
  Else
    kfl3a = 1
    If (ktab3>=8) kfl3a = 2
    If (ktab3>=11) kfl3a = 3
    If (ktab3>=16) kfl3a = 4
    kfl3b = (ktab3-6-kfl3a*(kfl3a-2))/2
    kfl3 = 1000*kfl3a + 100*kfl3b + 1
    If (kfl3a==kfl3b .Or. ktab3/=6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3 = kfl3 + 2
    kfl3 = isign(kfl3, kfl1*(13-2*ktab1))
  End If
  If (kfl3a==kfl1a .And. kfl3b==kfl1b .And. (kfl3a<=3 .Or. kfl3b/=0)) Then
    rfl = rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+25*ktabs)+parf(145+80*ktab1+25*ktabs))
    kf = 110 + 2*ktabs + 1
    If (rfl>parf(143+80*ktab1+25*ktabs)) kf = 220 + 2*ktabs + 1
    If (rfl>parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+25*ktabs)) kf = 330 + 2*ktabs + 1
  Else If (ktab1<=6 .And. ktab3<=6) Then
    kfla = max(ktab1, ktab3)
    kflb = min(ktab1, ktab3)
    kfs = isign(1, kfl1)
    If (kfla/=kf1a) kfs = -kfs
    kf = (100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
  Else If (ktab1>=7 .And. ktab3>=7) Then
    kfs = isign(1, kfl1)
    If (kfl1a==kfl3a) Then
      kfla = max(kfl1b, kfl3b)
      kflb = min(kfl1b, kfl3b)
      If (kfla/=kfl1b) kfs = -kfs
    Else If (kfl1a==kfl3b) Then
      kfla = kfl3a
      kflb = kfl1b
      kfs = -kfs
    Else If (kfl1b==kfl3a) Then
      kfla = kfl1a
      kflb = kfl3b
    Else If (kfl1b==kfl3b) Then
      kfla = max(kfl1a, kfl3a)
      kflb = min(kfl1a, kfl3a)
      If (kfla/=kfl1a) kfs = -kfs
    Else
      Call luerrm(2, '(LUKFDI:) no matching flavours for qq -> qq')
      Goto 100
    End If
    kf = (100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
  Else
    If (ktab1>=7) Then
      kfla = kfl3a
      kflb = kfl1a
      kflc = kfl1b
    Else
      kfla = kfl1a
      kflb = kfl3a
      kflc = kfl3b
    End If
    kfld = max(kfla, kflb, kflc)
    kflf = min(kfla, kflb, kflc)
    kfle = kfla + kflb + kflc - kfld - kflf
    If (ktabs==0) kf = isign(1000*kfld+100*kflf+10*kfle+2, kfl1)
    If (ktabs>=1) kf = isign(1000*kfld+100*kfle+10*kflf+2*ktabs, kfl1)
  End If
  If (kfl2/=0) kfl3 = 0
  kc = lucomp(kf)
  If (kc==0) Then
    Call luerrm(2, '(LUKFDI:) user-defined flavour probabilities '//'failed')
    Goto 100
  End If
  Return
End Subroutine lukfdi


      subroutine airctr_part(iflg,ndummy,zone)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To manage the isothermal air-water calculations.
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.30
!D2
!D2 $Log:   /pvcs.config/fehm90/src/airctr_part.f_a  $
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.2 Heat- and mass-transfer equations
!D3 2.3.3 Noncondensible gas flow equations
!D3 2.5.1 Implement time-step mechanism
!D3
!**********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!**********************************************************************

      use comdti
      use comai
      use combi
      use comci
      use comdi
      use comei
      use comfi
      use comgi
      use comii
      use comxi
      use davidi
      use comflow
      use comsplitts
      use com_part
      implicit none

      integer zone
      integer iflg,ndummy,ico2d,ndum,ieoss,iieoss,iwelbs,i,mid
      integer mi,i1,i2,ilev,mlev,il,md,irlpsv,irlptsv,nr1
      integer nr2,irdofsv
      integer ja
      real*8 tref,pref,pssv,ssv,phisv,dmpfd,dmefd,dqd,rqd,qcd
      real*8  strd_part
      real*8 inflow_thstime,inen_thstime,denht,deneht

      real*8 dels,delp,dfdum11,dfdum12,dfdum21,dfdum22
      real*8 dfdum11i,dfdum12i,dfdum21i,dfdum22i,detdf
      real*8 fdum01,fdum02,sx1d
      save tref,pref

C ? ico2d not passed in, not initialized
      ico2d = 0
c     return if no air present
      if(ico2.lt.0) then
c     iflg is used to tell if call is for initialization
         if(iflg.eq.0) then
            qtc=0.0
            qtotc=0.0
            amc=0.0
c
c     read in reference pressure and temperature
c
            read(inpt,*) tref,pref
c
c     set max and min values of p and t
c
            pmin(1)=-1.e05
            pmax(1)=1.e05
            tmin(1)=-1.e05
            tmax(1)=1.e05

c	Read in NAPL properties for SZ NAPL case

            if(ico2.eq.-3) then
               read(inpt,*) dennapl, viscnapl
            end if
         elseif(iflg.eq.-1) then

c
c     calculate density,compressibility,and viscosity of water
c
            ndum=neq
            irdofsv=irdof
            irdof=0
            neq=1
            dtot=1.0
            pssv=ps(1)
            ps(1)=1.0
            ieoss=ieos(1)
            iwelbs=iwelb
            iwelb=0
            ssv=s(1)
            irlpsv=irlp(1)
            irlptsv=irlpt(1)
            s(1)=1.0
            iieoss=iieos(1)
            ieos(1)=1
            iieos(1)=1
            phisv=phi(1)
            phi(1)=pref
            t(1)=tref
            irlp(1)=1
            irlpt(1)=1
            dmpfd=dmpf(1)
            dmefd=dmef(1)
            dqd=dq(1)
            call thermw(0)
            irdof=irdofsv
            neq=ndum
            ieos(1)=ieoss
            iieos(1)=iieoss
            phi(1)=phisv
            ps(1)=pssv
            s(1)=ssv
            iwelb=iwelbs
            irlp(1)=irlpsv
            irlpt(1)=irlptsv
c     reference density is in crl(1,1)
c     reference liquid viscosity is in crl(2,1)
c     reference compressibility is in crl(3,1)
c     reference pressure in crl(4,1)
c     reference air viscosity is in crl(5,1)
            crl(1,1)=rolf(1)
            crl(2,1)=1.0/(dil(1)/rolf(1))
            crl(3,1)=dmpf(1)/rolf(1)
            crl(4,1)=pref
            crl(5,1)=182.e-07
            crl(6,1)=tref
            if(ico2d.eq.-1) then
               crl(7,1)=1.0
            else
               crl(7,1)=0.0
            endif

            dmpf(1)=dmpfd
            dmef(1)=dmefd
            dq(1)=dqd
c
c     make thernmal conductivities small
c
c GAZ 10-23-98 eliminate thermal conductivities for isothermal
c           do i=1,n0
c              thx(i)=1.e-30
c              thy(i)=1.e-30
c              thz(i)=1.e-30
c           enddo
c
c     initialize 2-phase regions
c
            do i=1,n0
               ieos(i)=2
            enddo

         elseif(iflg.eq.1) then
c
c     determine phase state
c
           if(irdof.ne.13) then
c pnx used to be set in the following loops -- currently removed
            if (iad.eq.0) strd = 1.0
               do  mid=1,neq
                  mi=mid+ndummy
c
                  if(s(mi).lt.1.0.and.ieos(mi).eq.1) then
                     if(iad.eq.1) strd = strd_iter
                     strd = strd_iter
                     ieos(mi)=2
c                    call phase_timcrl(days,day,dtot,dtotdm)
c
                  else if(s(mi).gt.0.0.and.ieos(mi).eq.3) then
                     if(iad.eq.1) strd = strd_iter
                     strd = strd_iter
                     ieos(mi)=2
c                    call phase_timcrl(days,day,dtot,dtotdm)
c
                  else if(s(mi).gt.1.0.and.ieos(mi).eq.2) then
                     if(iad.eq.1) strd = strd_iter
                     ieos(mi)=1
c                    call phase_timcrl(days,day,dtot,dtotdm)
c
                  else if(s(mi).le.0.0.and.ieos(mi).eq.2) then
                     if(iad.eq.1) strd = strd_iter
                     s(mi)=0.0
                     strd = strd_iter
                     ieos(mi)=3
c                    call phase_timcrl(days,day,dtot,dtotdm)
c
                  endif
               enddo
               do  mid=1,neq
                  mi=mid+ndummy

                  if(phi(mi).lt.1.d-2) then
                     if(iad.eq.1) strd = strd_iter
                     phi(mi)=1.d-2
                     if (so(mi).ge.1.0) then
                      s(mi)= 0.999
                      phi(mi)=5.d-2
                      strd = strd_iter
                     endif
                  endif
c
                  if(s(mi).lt.0.0) then
                    if(iad.eq.1) strd = strd_iter
                     s(mi)=0.0
c                    strd = strd_iter
                  endif
c
                  if(s(mi).gt.1.0) then
                     if(iad.eq.1) strd = strd_iter
c                    s(mi)=1.0
c                    strd = strd_iter
                  endif
c
               enddo
           endif
c gaz taken out 4-11-2001
c              if(ihead.ne.0) then
c               do  mid=1,neq
c                 mi=mid+ndummy
c                 if(ka(mi).lt.0.and.phi(mi).lt.crl(4,1)) then
c                    pflow(mi)=crl(4,1)
c                    wellim(mi)=1.e-2
c                    esk(mi)=-1.0
c                 endif
c               enddo
c              endif
         elseif(iflg.eq.2) then
          if(abs(irdof).ne.14) then
c
c           update solution
c
c       called externally for each zone (gaz 11-20-2003)
c          do zone = 1, 2

            nr1=nrhs_part(zone,1)
            nr2=nrhs_part(zone,2)
	      bp = 0.0

c           strd is passed through common
            do i=1,neq_part(zone)
               i1=i+nr1
               i2=i+nr2
               mi = index_part(zone,i)
               strd_part= repeat_part(mi)
               phi(mi)= phi(mi)-bp_part(zone,i1)*strd*
     &             strd_part
               s(mi)= s(mi)-bp_part(zone,i2)*strd*
     &             strd_part

               bp(index_part(zone,i)+nrhs(1)) =
     &          + bp(index_part(zone,i)+nrhs(1))
     &          + bp_part(zone,i1)*strd*strd_part
               bp(index_part(zone,i)+nrhs(2)) =
     &          + bp(index_part(zone,i)+nrhs(2))
     &          + bp_part(zone,i2)*strd*strd_part
            enddo
c
c turn off initial parent BC if necessary
c

c          enddo
c
c call cascade redistribution if requested
c
           if(iflux_ts.ne.0) then
            call cascade_sat(1)
           endif
c
          else
c
c           update solution(with exact mass balance)
c
            nr1=nrhs(1)
            nr2=nrhs(2)
c           strd is passed through common
            do i=1,neq
               i1=i+nr1
               i2=i+nr2
               phi(i)=phi(i)-bp(i1)*strd
            enddo
c
c           call wellrate(0,0)
c           call thrair(0)
            call interblock_iso(0)

          endif
         elseif(iflg.eq.3) then
            if(ico2.eq.-3) then
c     call isothermal SZ NAPL thermodynamics
               call thrsznapl(ndummy)
            else
c     call isothermal air water thermodynamics
               if(ifree.ne.0) then
                 call wtsictr(2)
                 call thrair(ndummy)
                 call wtsictr(4)
               else
                 call thrair(ndummy)
               endif
            end if
         elseif(iflg.eq.4) then
c     call equation generation and load a array

c    gensl2 must be passed the zone

            call gensl2_part(zone)

        elseif(iflg.eq.-4) then
c solve explicit equations
         call gensl2_explicit
c
         elseif(iflg.eq.5) then
            if(ntty.eq.2) then
c
c     output for air
c
               if (iout .ne. 0) write(iout,803)
               if (iatty .ne. 0) write(iatty,803)
c
c     organize differing amounts of output for dpdp and dual solutions
c
c
               if(idualp.ne.0) then
                  ilev=3
                  mlev=m/3
               else if(idpdp.ne.0) then
                  ilev=2
                  mlev=m/2
               else
                  ilev=1
                  mlev=m
               endif

               do il=1,ilev
                  if(il.ne.1) then
                     if (iout .ne. 0) write(iout,702) il
                     if (iatty .gt. 0) write(iatty,702) il
 702                 format(2x,'Matrix Level = ',i1)
                  endif
                  do i=1,mlev
                     md=  nskw(i+(il-1)*mlev)
                     rqd= sk(md)
                     qcd=qh(md)
                     if(ihead.ne.0) then
                        if (iout .ne. 0) write(iout,804)
     &                       md,max(phi(md)-phi_inc,0.1d00),
     &                       0.d00,max(phi(md)-phi_inc,0.1d00),qcd
                        if(iatty.ne.0)
     &                       write(iatty,804)
     &                       md,max(phi(md)-phi_inc,0.1d00),
     &                       0.d00,max(phi(md)-phi_inc,0.1d00),qcd
                     else
                        if (iout .ne. 0) write(iout,804)
     &                       md,phi(md),pcp(md),
     &                       phi(md)-pcp(md),qcd
                        if(iatty.ne.0)
     &                       write(iatty,804) md,phi(md),pcp(md),
     &                       phi(md)-pcp(md),qcd
                     endif
                  enddo
               enddo
 803           format(/,20x,'Nodal Information (Vapor)',/,2x,'Node',3x,
     *              'air(vp) pres',3x,'cap pres ',3x,'liquid pres '
     *              ,3x,'source/sink(kg/s)')
 804           format(i6,5x,f8.3,1x,f10.3,4x,f10.3,5x,g12.4)
c     calculate global mass and energy flows
               if (iout .ne. 0) then
                  write(iout,703)
                  write(iout,704) qtotei
                  write(iout,705) qtote
                  write(iout,706) qte
                  write(iout,707) dife
               end if
               if(iatty.ne.0) then
                  write(iatty,703)
                  write(iatty,704) qtotei
                  write(iatty,705) qtote
                  write(iatty,706) qte
                  write(iatty,707) dife
               endif
 703           format(/,20x,'Global Mass Balances (Vapor)')
 704           format(1x,'Vapor discharge this time step: ',e14.6,' kg')
 705           format(1x,'Total vapor discharge: ',9x,e14.6,' kg')
 706           format(/,1x,'Net kg vapor discharge (total out-total ',
     &              'in): ',e14.6)
 707           format(1x,'Conservation Error: ',25x,e14.6)
            endif
         elseif(iflg.eq.6) then
c
c     store sk in qc
c     initialize t,to,tini,iieos
c
            tref=crl(6,1)
            do i=1,n
               qc(i)=sk(i)
               if(to(i).eq.0.0d00) then
                 t(i)=tref
                 to(i)=tref
                 tini(i)=tref
               endif
               iieos(i)=1
               if(ieos(i).eq.1) then
                  ieos(i)=2
                  s(i)=1.0
                  so(i)=1.0
               endif
             if(abs(irdof).eq.14) then
              denj(i)=1.0-s(i)
             endif
            enddo
c
c check also for free surface calcs
c
           if(ifree.ne.0) then
            call wtsictr(1)
c
           endif
         elseif(iflg.eq.7) then
c
c convert from head to pressure
c
          call headctr(3,0,0.0,0.0)

         elseif(iflg.eq.8) then
c
c convert from pressure to head
c
          call headctr(2,0,0.0,0.0)
         elseif(iflg.eq.9) then
c
c convert from head to pressure boundary value
c
          call headctr(6,0,0.0,0.0)

         elseif(iflg.eq.10) then
c
c convert from head to pressure boundary and initial
c conditions (based on pair = pref at max height)
c correct for negative pressures
c
          call head_2phase(0)

         endif
      endif

      return
      end


      SUBROUTINE gpggaa( ihour, min, isec, mils, dlat, dlong, istat )
!****  mils will be 9999 if it's not in the nmea string.
!****  GPGGA decodes a NMEA $GPGGA string that was read via subroutine
!****  rline.  The string must be in rline common buffer because
!****  that's where subroutine getoke expects it.
!
! mod 4 June 2004 - set everything to zero if the first field is empty.
! mod 8 October 2006 - set everything to zero if the lat or long are empty.
! mod 19 June 2007 - Read minutes as REAL*8
! mod 23 Feb 2016 - UW Micro Eel  is bad:
!   $GPGGA,230741.60,3258.8455102,N,11758.7932197,W,1,0?,1.2,5.0,M,-33.6,M,,*58
!         so just return after doing dlong and forget the other things nobody uses
! mod 29 Mar 2016 - Geo Eel might screw up any field, so check every field for proper length
!         and keep track of a delta_lat and delta_long and apply them to the last lat/long
!         if the current lat/long is screwed up.
!                 - add mils
!  $GPGGA,084117.20,3308.8398645,N,11841.9110338,W,1,09,0.9,7.2,M,-34.0,M,,*51
!  $GPGGA,084122.20,3308.8382883,N,11841.9030828,W,1,09,0.9,6.9,M,-34.0,M,,*5B
!  $GPGGA,08412w.20,3308.8367035,N,11841.8953377,W,1,09,0.9,7.2,M,-34.0,M,,*56   BAD timestamp
!  $GPGGA,084132.20,3308.8352674,N,11851.8870243,W,1,09,0.9,7.0,M,-34.0,M,,*53   BAD longitude minute
!  $GPGGA,084137.20,3308.8335151,N,11841.8790745,W,1,09,0.9,6.6,M,-34.0,M,,*52
!
! mod 29 Mar 2016 - change to gpggaa to delete unused arguments and add istat
!         istat = 0 if ok
!               = 1 if not ok - an error ocurred
! mod 13 Apr 2016 - detecting bad $GPGGA is uglier than I thought.  Don't try to correct anything
!        until all fields are examined.  i.e. lat may pass being the right length and being a
!        number, but may be bad - the long may not be detected bad.
!
      REAL*8 dlat, dlong, dtemp, dmin
      REAL*8 delta_lat/99999./, delta_long/99999./, last_lat/0/,
     &       last_long/0/
      INTEGER dgps_sec
      CHARACTER*3 dgps_id
      INTEGER ishort/1/
      CHARACTER*82 out
      SAVE

      istat = 0
      CALL getokec( out, n )
      IF( out(1:6) .NE. '$GPGGA' ) THEN
          PRINT *,'  ***  ERROR  ***  Nav string is not $GPGGA',
     &        out(1:n)
          STOP
      ENDIF
!
!     get the timestamp
      CALL getokec( out, n )
      IF( n .LT. 6 ) GOTO 9000
!      READ ( out, '(I2,I2,I2)' ) ihour, min, isec
!      Unfortunately, g77 crashes if the above is bad
      CALL dcode( out(1:1), 2, areal, jstat )
      IF( jstat .EQ. 2 ) THEN
          ihour = NINT(areal)
      ELSE
          ihour = 999
          GOTO 10000
      ENDIF
      CALL dcode( out(3:3), 2, areal, jstat )
      IF( jstat .EQ. 2 ) THEN
          min = NINT(areal)
      ELSE
          min = 999
          GOTO 10000
      ENDIF
      CALL dcode( out(5:5), 2, areal, jstat )
      IF( jstat .EQ. 2 ) THEN
          isec = NINT(areal)
      ELSE
          isec = 999
          GOTO 10000
      ENDIF
      mils = 9999
!      IF( n .EQ. 9 ) READ ( out, '(7X,I2)' ) mils
      IF( n .EQ. 9 ) THEN
          CALL dcode( out(8:8), 2, areal, jstat )
          IF( jstat .EQ. 2 ) THEN
              mils = NINT(areal)
          ELSE
              mils = 9999
              GOTO 10000
          ENDIF
      ENDIF
!
!     Get the lat
      CALL getokec( out, n )
      IF( n .LT. 9 ) THEN        ! some "old" units didn't have much precision
          IF( delta_lat .EQ. 99999. ) GOTO 9000
!         if lat is bad, long will be too
          GOTO 10000
      ENDIF
      CALL dcode(out, 2, deg, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      ideg = deg
      CALL ddcode(out(3:n), n-2, dmin, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      dlat = DFLOAT(ideg)
      dlat = dlat + dmin / 60.D0
      CALL getokec( out, n )
      IF( n .NE. 1 ) GOTO 10000
      IF( out(1:1) .EQ. 'S' ) dlat = -dlat
!
!     Get the long
      CALL getokec( out, n )
      IF( n .LT. 9 ) THEN        ! some "old" units didn't have much precision
          IF( delta_long .EQ. 99999. ) GOTO 9000
          GOTO 10000
      ENDIF
      CALL dcode(out, 3, deg, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      ideg = deg
      CALL ddcode(out(4:n), n-3, dmin, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      dlong = DFLOAT(ideg)
      dlong = dlong + dmin / 60.D0
      CALL getokec( out, n )
      IF( n .NE. 1 ) GOTO 10000
      IF( out(1:1) .EQ. 'W' ) dlong = -dlong
!
!
!     clean up for the next fix
      IF( last_lat + last_long .NE. 0. ) THEN     ! can only do this on/after second fix
          delta_lat = dlat - last_lat
          delta_long = dlong - last_long
      ENDIF

 9000 CONTINUE
      last_lat = dlat
      last_long = dlong
      RETURN

10000 CONTINUE
      dlat = last_lat + delta_lat
      dlong = last_long + delta_long
      istat = 1
      GOTO 9000

      END


	SUBROUTINE GH_WIPL ( timstr, wname, origc, wocen, wadnm, wwnd,
     +                       fdate, mxwd, lndext, nc, nstrm, tzone,
     +                       wtype, idisp, iret )
C************************************************************************
C* GH_WIPL								*
C*									*
C* This subroutine draws the wind intensity probability graph.		*
C*									*
C* GH_WIPL ( TIMSTR, WNAME, ORIGC, WOCEN, WADNM, WWND, FDATE, MXWD,     *
C*           LNDEXT, NC, NSTRM, TZONE, WTYPE, IDISP, IRET )		*
C*									*
C* Input parameters:							*
C*      TIMSTR          CHAR*           Advisory valid time string      *
C*      WNAME           CHAR*           Tropical storm name             *
C*      ORIGC           CHAR*           Issuing center                  *
C*      WOCEN           CHAR*           Ocean identifier                *
C*      WADNM           CHAR*           Advisory number                 *
C*	WWND    	CHAR*		Current max sustained wind	*
C*      FDATE (NC,*)    CHAR*           Forecast date/time strings      *
C*      MXWD (NC,*)     INTEGER         Forecast max wind               *
C*      LNDEXT (NC,*)   CHAR*           Inland/Extratropical flag       *
C*      NC              INTEGER         Maximum number of lat/lon pairs *
C*      NSTRM           INTEGER         Number of decoded files         *
C*      TZONE           CHAR*           Current time zone		*
C*      WTYPE           CHAR*           Storm type			*
C*      IDISP           INTEGER         Storm dissipating flag		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* Log:									*
C* A. Hardy/GSC		 4/01	Created					*
C* A. Hardy/GSC		 6/01	Added wtype, GQLINE, GSLINE		*
C* A. Hardy/GSC		 6/01	Added color tag; fixed prolog		*
C* A. Hardy/SAIC	 8/01	Added ddev to gh_wrel calling sequence  *
C* D. Kidwell/NCEP	 4/02	Changed PS check; cleaned up            *
C* A. Hardy/NCEP	 3/03   Modified yoffset for 'INLAND' label	*
C* m.gamazaychikov/SAIC	06/06	Added code to handle CP storms		*
c* S. Gilbert/NCEP      07/06   Added new argument origc                *
C* X. Guo/CWS		02/10   Used Post-Tropical instead of           *
C*                               Extratropical                          *
C* D. Zelinsky/NCEP/NHC 10/15   Commented out tzone assignment for EP   *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)   wname, timstr, wocen, wadnm, tzone, wtype,
     +                  fdate(nc,*), lndext(nc,*), wwnd, origc
C
        INTEGER         mxwd(nc,*), iyaxis(5,6), prblvl(4), iymph(2,13)
     	CHARACTER       curtim*15, chinex(6), advnm*3, ocean*6
C
	CHARACTER	panel*(LLMXLN),
     +	                parms*12, prmtyp*1, range*20, witnes*20,
     +             	ctlbl (7)*3, ttlstr*72
	CHARACTER       fcsttl*25, nhcttl1*32, timest*25, nhcttl2*28,
     +                  fmonth*3, ampm*2, zone2*3, cyear*4, cday*2,
     +                  chr*2, fuldat(6)*13, newdate*13, lndlbl*9,
     +                  fmon*9, fday*9, ddev*12, coltag*33
        INTEGER         jtarr(5)
	REAL		xtlbl (50), view (4), data(LLMXTM),
     +                  datarng(LLMXTM), ylbl (LLAXIS), xbox (5),
     +			ybox (5)
        LOGICAL         proces, axflg, tmflg
C*
	CHARACTER	tpanl*24
	DATA		tpanl  / '.09;.10;.94;.85' /
C------------------------------------------------------------------------
C
C*      Query current settings.
C
        CALL GH_SAVE ( ier )
C
C*      Reverse black and white if device is for postscript.
C
        CALL GQDEV  ( ddev, iunit, iatyp, iret )
        IF  ( ddev(:2) .eq. 'PS' )  THEN
            iwht = 31
C
C*	    Force a black background for postscript.
C
	    CALL GSCOLR ( 1, ier )
	    xbox (1) = 0.
            ybox (1) = 0.
            xbox (2) = 0.
            ybox (2) = .8
            xbox (3) = 1.
            ybox (3) = .8
            xbox (4) = 1.
            ybox (4) = 0.
            xbox (5) = 0.
            ybox (5) = 0.
            CALL GFILL ( 'N', 5, xbox, ybox, ier )
          ELSE
            iwht = 1
        END IF
	CALL GSCOLR ( iwht, ier )
C
C*	Read in the variables.
C
        panel  =  '0'
	ibwidt = 3
C
C*	Set parameter information.
C
        parms = 'SMPH'
        ntparm  = 1
        iptprm  = 1
        prmtyp  = 'R'
        range   = ' '
        witnes  = ' '
        nparms = 1
C
C*	Set information about x axis.
C
        ntime = 6
        xstrt = 2.875
        xstop = 0.0
C
        xtlbl(6) = 0.0
        xtlbl(5) = 1.0
        xtlbl(4) = 1.5
        xtlbl(3) = 2.0
        xtlbl(2) = 2.5
        xtlbl(1) = 2.875
C
        ctlbl(1) = 'NOW'
        ctlbl(2) = '12'
        ctlbl(3) = '24'
        ctlbl(4) = '36'
        ctlbl(5) = '48'
        ctlbl(6) = '72'
C
        xmndst = 0.375
        ilbfrq = 1
        iglfrq = 1
        itmfrq = 1
	xmndst = xmndst * 3.
C
C*	Set the TEXT information.
C
        itxtfnt = 21
        itxhw = 2
        sztext = 1.2
        itxwid = 1
        ibrdr = 111
        irrotn = 0
        ijust = 2
C
C*      Calculate the probability lines.
C
        ocean = wocen
        CALL GH_WIER ( timstr, ocean, origc, wwnd, fdate, mxwd, NC,
     +                 nstrm, iyaxis, prblvl, proces, itwnd, iret )
C
C*	Set margins.
C
	IF  ( proces )  THEN
	    CALL GSGMGN  ( 7., 3., 7., 1., ier )
	END IF
C
C*	Set the panel information and store view coordinates.
C
	CALL GG_PANL ( panel, ier )
	CALL GQVIEW  ( view (1), view (2), view (3), view (4), ier )
C
C*      Set up the line arrays.
C
        DO jj =  1,itwnd
            iymph ( 1, jj ) = iyaxis(1,jj)
            iymph ( 1, jj+itwnd ) = iyaxis(4,(itwnd+1)-jj)
            iymph ( 2, jj ) = iyaxis(2,jj)
            iymph ( 2, jj+itwnd ) = iyaxis(3,(itwnd+1)-jj)
C
            chinex (jj) = lndext(jj,nstrm)
        END DO
        iend = (itwnd * 2 ) + 1
        iymph ( 1, iend ) = iyaxis(1,1)
        iymph ( 2, iend ) = iyaxis(2,1)
C
C*	Set full date string array.
C
        curtim = timstr
        advnm = wadnm
        fdate(1,1) = curtim(5:)
        DO ii = 1, itwnd
            newdate = curtim(1:4) // fdate (ii,1)
            CALL TI_DTM4 ( newdate, fuldat(ii), ier )
        END DO
C
C*      Begin the plotting.
C
	IF  ( ( proces ) .and. (idisp .ne. 2 ) )  THEN
            CALL ST_LSTR ( curtim, lens, ier)
            CALL ST_LSTR ( tzone, lenz, ier)
C
C*	    Add titles.
C
            IF ( ocean(1:2) .eq. 'CP' ) tzone = 'H'
C            IF ( ocean(1:2) .eq. 'EP' ) tzone = 'P'
            IF ( origc(1:4) .eq. 'CPHC' ) tzone = 'H'
            timest = curtim(:lens)
            CALL ST_LSTR ( timest, lent, ier)
	    CALL GH_TIME ( timest(:lent), tzone(:lenz), jtarr, hours,
     +                     zone2, fmonth, fmon, fday, ampm, iret )
C
C*	    Add bottom time/date title.
C
            CALL ST_INCH (jtarr(1), cyear, ier)
            CALL ST_INCH (jtarr(3), cday, ier)
            CALL ST_INCH (jtarr(4), chr, ier)
            icttl = 6
            linttl = -2
            CALL ST_LSTR ( wname, lenn, ier)
            CALL ST_LSTR ( advnm, lena, ier)
            CALL ST_LSTR ( chr, lenh, ier)
            CALL ST_LSTR ( ampm, lenp, ier)
            CALL ST_LSTR ( zone2, lenz, ier)
            CALL ST_LSTR ( fmon, lenm, ier)
            CALL ST_LSTR ( cday, lend, ier)
            CALL ST_LSTR ( cyear, leny, ier)
C
            CALL ST_LCUC ( wname, wname, ier )
            ttlstr  =  wname ( :lenn ) // '    ADVISORY   '
     +                   // advnm( :lena)  //'  '// chr(:lenh)//':00'
     +                   // '  ' // ampm(:lenp) //'  '// zone2 (:lenz)
     +                   // '  '// fmon(:lenm)
     +                   //'  '// cday(:lend) // '  ' // cyear(:leny)
C
            coltag = 'i_date_title'
       	    CALL ST_LSTR ( coltag, lens, ier )
            CALL GH_COLR ( coltag(:lens), 6, ier)
            CALL GSTEXT ( 22, 2, 1.0, 1, 110, 1, 2, ier )
            CALL GG_WSTR ( ttlstr, linttl, ier )
C
C*	    Add bottom time label.
C
 	    CALL GSCOLR  ( iwht, ier )
            fcsttl = 'FORECAST PERIOD (HOURS)'
            linbot = -4
	    CALL GG_WSTR ( fcsttl, linbot, ier )
C
C*	    Add top two labels.
C
            nhcttl1 = 'NHC MAXIMUM 1-MINUTE WIND SPEED'
            IF ( origc (:4) .eq. 'CPHC' )
     +         nhcttl1 = 'CPHC MAXIMUM 1-MINUTE WIND SPEED'
            lintop = +4
	    CALL GG_WSTR ( nhcttl1, lintop, ier )
            nhcttl2 = 'FORECAST AND PROBABILITIES'
            lintop = +6
	    CALL GG_WSTR ( nhcttl2, lintop, ier )
C
C*	    Set the panel for plotting of winds.
C
	    CALL GH_WPNL  ( view, tpanl, ier )
C
C*	    Plot on the left and then the right.
C
	    axflg = .true.
	    tmflg = .true.
            ntot = iend
            ii = 1
            DO mm = 1,2
               DO kl = 1, ntot
                  datarng(ii) = iymph(mm,kl)
                  ii = ii + 1
               END DO
            END DO
            itot = ii - 1
	    DO  j = 1, 2
C
C*	        Set up the graph coordinates.
C
	        IF  ( ntparm .gt. 0 )  THEN
	           CALL GSCOLR  ( iwht, ier )
	           CALL GSLINE  ( 1, 0, ibwidt, 0, ier )
                   CALL GSTEXT ( 2, 2, 1.2, 1, 110, 1, 2, ier )
C
 	           CALL GH_WGRF  ( j, 1, itot, datarng,
     +			  	     prmtyp, iptprm, range,
     +				     axflg, xstrt, xstop, xtlbl, ctlbl,
     +				     ntime, tmflg, ilbfrq, itmfrq,
     +				     witnes, parms, ntparm,
     +                               ystrt, nylbl, ylbl, iwht, iret )
                    iret = 0
		    IF ( iret .eq. 0 )  axflg = .false.
                  ELSE
		    iret = -1
	        END IF
C
C*	        Plot the parameters.
C
                DO ii = 1, iend
                    data(ii) = iymph(j,ii)
                END DO
C
	        IF  ( iret .eq. 0 )  THEN
                    IF ( j .eq. 1 ) THEN
                        coltag = 'i_ten_percent_fill'
       			CALL ST_LSTR ( coltag, lens, ier )
        		CALL GH_COLR ( coltag(:lens), 17, ier)
                      ELSE IF  (j .eq. 2 ) THEN
                        coltag = 'i_twenty_thirty_fill'
       			CALL ST_LSTR ( coltag, lens, ier )
        		CALL GH_COLR ( coltag(:lens), 2, ier)
                    END IF
C
	            CALL GH_WREL  ( origc, ddev, parms, data, ntot,
     +                             xmndst, xtlbl, iyaxis, prblvl,
     +                             itwnd, iend, ier )
	        END IF
	    END DO
C
C*	    Draw the bottom x axis, labels, tick marks and witness lines.
C
            axflg = .true.
            CALL GSTEXT ( 2, 2, 1.2, 1, 110, 1, 1, ier )
            CALL GSCOLR ( iwht, ier )
	    CALL GSTICK  ( 2, 1.5, ier )
            CALL GSLINE  ( 10, 0, 2, 0, ier )
	    CALL GAAXIS  ( 1, ystrt, axflg, ilbfrq, itmfrq,
     +			           iglfrq, ntime, xtlbl, ctlbl, ier )
C
C*	    Draw the y axes, labels, tick marks and witness lines.
C
 	    CALL GAAXIS  ( 2, xstrt, axflg, 0, 0, 0, 0, xtlbl, ctlbl,
     +			   ier )
 	    CALL GAAXIS  ( 4, xstop, axflg, 0, 0, 0, 0, xtlbl, ctlbl,
     +			   ier )
C
	    jside = 2
	    xxxxx = xstrt
	    CALL GDAXIS  ( jside, xstrt, .false., 1, 1, 0, 0, nylbl,
     +			       ylbl, ier )
            CALL GSTEXT ( 2, 2, 1.2, 1, 110, 1, 2, ier )
            jside = 4
	    CALL GDAXIS  ( jside, xstop, .false., 1, 1, 0, 0, nylbl,
     +			       ylbl, ier )
C
            ixoff = 0
            iyoff = -2
            CALL GSTEXT ( 2, 2, 1.0, 1, 111, 1, 2, ier )
            DO im = 2, itwnd
                IF ( (chinex (im) .eq. 'I') .or.
     +                           (chinex (im) .eq. 'P' ) )THEN
                    IF (chinex (im) .eq. 'I') THEN
                        lndlbl = 'INLAND'
                        iyoff = -1
                        IF ( im .eq. 6)  THEN
                            ixoff = -8
                        END IF
                      ELSE IF  (chinex (im) .eq. 'P' ) THEN
                        lndlbl = 'POST-TROP'
                        IF ( im .eq. 6)  ixoff = -4
                    END IF
                    CALL ST_LSTR ( lndlbl, lenl, ier )
 		    CALL GTEXT  ( 'M', xtlbl(im), ystrt+4,
     +                             lndlbl(:lenl), 0.0,ixoff,iyoff, ier)
                END IF
            END DO
C
C*          If last forecast or extra tropical at 12h.
C
	  ELSE
            CALL ST_LSTR ( advnm, lena, ier)
	    CALL GH_NOPB  ( advnm, wtype, wname, ier )
        END IF
C
C*      Plot NOAA logo.
C
        CALL GLOGO ( 'N', .93, .06, 2.5, 2, 1, ier )
C
C*      Plot NWS logo.
C
        CALL GLOGO ( 'N', .08, .06, 2.5, 2, 2, ier )
C
C*	Reset view to initial settings.
C
	CALL GSVIEW  ( view (1), view (2), view (3), view (4), ier )
C
C*      Reset the saved attributes.
C
        CALL GH_REST ( ier )
C*
        RETURN
	END


#ifdef PICO

    module Calculator_PICO
    use CosmologyTypes
    use CosmoTheory
    use Calculator_CAMB
    use CAMB, only : CAMBParams_Set, highL_unlensed_cl_template, ThermoDerivedParams, nthermo_derived, &
        BackgroundOutputs, lmin, CAMBParams
    use Errors !CAMB
    use settings
    use likelihood
    use Calculator_Cosmology
    use GeneralTypes
    use fpico
    implicit none
    private

    Type, extends(CAMB_Calculator) :: PICO_Calculator
    contains
    procedure :: CMBToCAMB => PICO_CMBToCAMB
    procedure :: GetNewTransferData => PICO_GetNewTransferData
    procedure :: GetNewPowerData => PICO_GetNewPowerData
    procedure :: GetCosmoTheoryForImportance => PICO_GetTheoryForImportance
    procedure :: VersionTraceOutput => PICO_VersionTraceOutput
    procedure :: ReadParams => PICO_ReadParams
    end type PICO_Calculator

    public PICO_Calculator
    contains

    subroutine PICO_CMBToCAMB(this,CMB,P)
    class(PICO_Calculator) :: this
    class(CMBParams) CMB
    type(CAMBParams)  P

    call this%CAMB_Calculator%CMBToCamb(CMB,P)
    P%Reion%use_optical_depth = .true.
    P%OnlyTransfers = .true.
    if (.not. CosmoSettings%CMB_Lensing) call MpiStop('PICO assumes lensed CMB')

    end subroutine PICO_CMBToCAMB

    subroutine PICO_GetNewTransferData(this, CMB,Info,Theory,error)
    class(PICO_Calculator) :: this
    class(CMBParams) CMB
    class(TTheoryIntermediateCache), pointer :: Info
    class(TCosmoTheoryPredictions) :: Theory
    integer error
    !Do nothing
    end subroutine PICO_GetNewTransferData

    subroutine PICO_GetOutputArray(Theory,i,j, name)
    class(TCosmoTheoryPredictions) :: Theory
    integer i,j
    character(LEN=*) :: name
    integer(fpint) lmax, lmn

    if (CosmoSettings%cl_lmax(i,j)>0) then
        lmax = min(CosmoSettings%lmax_computed_cl,CosmoSettings%cl_lmax(i,j))
        lmn = lmin
        call fpico_read_output(name,Theory%Cls(i,j)%CL(lmin:),lmn,lmax)
    end if

    end subroutine PICO_GetOutputArray

    subroutine PICO_GetNewPowerData(this, CMB, Info, Theory, error)
    use ModelParams
    use ModelData
    class(PICO_Calculator) :: this
    class(CMBParams) :: CMB
    class(TTheoryIntermediateCache), pointer :: Info
    class(TCosmoTheoryPredictions) :: Theory
    integer error,i,j, lmaxCL,lmx
    type(CAMBParams) P
    integer(fpint) :: success
    real(mcp) :: highL_norm = 0
    integer, save, allocatable :: indicesT(:,:)

    if (.not. allocated(indicesT)) then
        allocate(indicesT(3,3))
        indicesT=0
        indicesT(1,1) =  C_Temp
        indicesT(2,2) =  C_E
        indicesT(2,1) =  CT_Cross
        indicesT(3,3) =  CT_B
    end if

    call this%CMBToCAMB(CMB, P)
    call CAMBParams_Set(P)
    call this%SetBackgroundTheoryData(CMB,Theory,error)

    if (p%InitPower%n_runrun(1)/=0 .or. p%InitPower%nt_run(1)/=0 .or. p%InitPower%ant(1)/=0) &
        & call MpiStop('PICO: currently unsupported initial power parameter')

    if (CosmoSettings%Use_LSS .or. CosmoSettings%get_sigma8) then
        call MpiStop('PICO: currently no MPK or sigma8')
    end if

    call fpico_reset_params()
    call fpico_set_param("ombh2", CMB%ombh2)
    call fpico_set_param("omch2", CMB%omch2)
    call fpico_set_param("omnuh2", CMB%omnuh2)
    call fpico_set_param("omvh2", CMB%omv*CMB%h**2)
    call fpico_set_param("omk", CMB%omk)
    call fpico_set_param("hubble", CMB%H0)
    call fpico_set_param("Alens", CMB%Alens)
    call fpico_set_param("w", CMB%w)
    call fpico_set_param("theta", CosmomcTheta())
    call fpico_set_param("helium_fraction", p%yhe)

    call fpico_set_param("massive_neutrinos", CMB%nnu)
    call fpico_set_param("scalar_spectral_index(1)",p%InitPower%an(1))
    call fpico_set_param("scalar_nrun(1)",p%InitPower%n_run(1))
    call fpico_set_param("initial_ratio(1)",p%InitPower%rat(1))
    call fpico_set_param("scalar_amp(1)",p%InitPower%ScalarPowerAmp(1))
    call fpico_set_param("pivot_scalar",p%InitPower%k_0_scalar)
    call fpico_set_param("pivot_tensor",p%InitPower%k_0_tensor)
    call fpico_set_param("re_optical_depth",CMB%tau)
    !    call fpico_set_param("force",1.d0)

    call fpico_reset_requested_outputs()
    if (P%WantCls) then
        call fpico_request_output("cl_TT")
        if (CosmoSettings%num_cls>1) then
            call fpico_request_output("cl_TE")
            call fpico_request_output("cl_EE")
            if (CosmoSettings%num_cls>2) then
                if (CosmoSettings%cl_lmax(3,3)>0) call fpico_request_output("cl_BB")
                if (CosmoSettings%num_cls>3) then
                    !                    call MpiStop('PICO: lensing output currently innaccurate')
                    !                    if (CosmoSettings%cl_lmax(4,4)>0) call fpico_request_output("cl_pp")
                end if
            end if
        end if
    end if
   ! if (P%WantTransfer) then
   !     call fpico_request_output("k")
   !     call fpico_request_output("pk")
   ! end if

    call fpico_compute_result(success)
    if (success == 0) then
        ! for now just reject if out of pico bounds
        !call mpiStop('PICO failed to get result')
        if (Feedback>1) write(*,*) 'PICO out of bounds'
        error = 1
        return
    end if
    error = 0
    if (P%WantCls) then
        call PICO_GetOutputArray(Theory,1,1, "cl_TT")
        if (CosmoSettings%num_cls>1) then
            call PICO_GetOutputArray(Theory,2,1, "cl_TE")
            call PICO_GetOutputArray(Theory,2,2, "cl_EE")
            if (CosmoSettings%num_cls>2) call PICO_GetOutputArray(Theory,3,3, "cl_BB")
            !            if (CosmoSettings%num_cls>3) call PICO_GetOutputArray(Theory,4,4, "cl_pp") need to change units, as in scalCls
        end if
    end if

    do i=1, min(3,CosmoSettings%num_cls)
        do j= i, 1, -1
            lmaxCL = CosmoSettings%cl_lmax(i,j)
            lmx = min(CosmoSettings%lmax_computed_cl, lmaxCL)
            if (lmx/=0) then
                associate( CL => Theory%Cls(i,j)%CL)
                    if (CosmoSettings%lmax_computed_cl < lmaxCL) then
                        if (highL_norm ==0) & !normally normalize off TT
                        & highL_norm = CL(lmx)/this%highL_lensedCL_template(lmx,indicesT(i,j))
                        CL(lmx+1:lmaxCL) =  highL_norm*this%highL_lensedCL_template(lmx+1:lmaxCL,indicesT(i,j))
                    end if
                end associate
            end if
        end do
    end do

    end subroutine PICO_GetNewPowerData

    subroutine PICO_GetTheoryForImportance(this, CMB, Theory, error)
    class(PICO_Calculator) :: this
    class(CMBParams) CMB
    class(TCosmoTheoryPredictions) Theory
    integer :: error

    call this%GetNewPowerData(CMB, null(), Theory, error)
    call this%GetNewBackgroundData(CMB,Theory,error)
    if (error==0) call this%SetDerived(Theory)

    end subroutine PICO_GetTheoryForImportance

    subroutine PICO_VersionTraceOutput(this, ReadValues)
    use GaugeInterface, only : Eqns_name
    class(PICO_Calculator) :: this
    class(TNameValueList) :: ReadValues

    call ReadValues%Add('Compiled_PICO_version', '3.3.0') !dynamic version variable?
    call this%CAMB_Calculator%VersionTraceOutput(ReadValues)

    end subroutine PICO_VersionTraceOutput

    subroutine PICO_ReadParams(this,Ini)
    class(PICO_Calculator) :: this
    class(TSettingIni) :: Ini

    call this%CAMB_Calculator%ReadParams(Ini)
    this%calcName ='PICO'

    !$ write(*,*) '**WARNING**: pico may not work when CosmoMC compiled with -openmp (why??)'

    call fpico_init(1_fpint)
    call fpico_load(Ini%Read_String_Default("pico_datafile", EnvDefault=.true.))
    call fpico_set_verbose(int(IfThenElse(Ini%Read_Logical("pico_verbose",.false.),1,0),fpint))

    end subroutine PICO_ReadParams

    end module Calculator_PICO
#endif


      subroutine solstore( mi )
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 To compute the tracer mass storage and sorption
CD1 terms of the residuals equations and their derivatives.
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 07-26-93      B. Robinson   22      Extracted from old version of
CD2                                     thermc to make code more modular
CD2
CD2 $Log:   /pvcs.config/fehm90/src/solstore.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:56   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:15:58   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:14:32   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:26:50   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:10:18   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:45:42 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.3   Fri Feb 02 11:44:46 1996   hend
CD2 Updated Requirements Traceability
CD2
CD2    Rev 1.2   01/28/95 14:20:58   llt
CD2 modified for the revised reactive transport module
CD2
CD2    Rev 1.1   03/18/94 16:16:00   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:27:54   pvcs
CD2 original version in process of being certified
CD2
C**********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3 Identifier   Type    Use     Description
CD3
CD3 mi           int      I      Position in concentration arrays for
CD3                              current unknown
CD3
CD3 Interface Tables
CD3
CD3 None
CD3
CD3 Files
CD3
CD3 None
CD3
C**********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4 Identifier  Type     Description
CD4
CD4
CD4 Global Types
CD4
CD4 NONE
CD4
CD4 Global Variables
CD4
CD4                      COMMON
CD4 Identifier   Type    Block   Description
CD4
CD4
CD4 Global Subprograms
CD4
CD4 None
CD4
C**********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5 Identifier   Type        Description
CD5
CD5 conc_min     real*8      Minimum concentration to be used in
CD5                          sorption related floating point
CD5                          calculations
CD5 rtol         real*8      Minimum value of density x saturation to
CD5                          be used in subsequent floating point
CD5                          calculations
CD5
CD5 Local Types
CD5
CD5 None
CD5
CD5 Local variables
CD5
CD5 Identifier   Type        Description
CD5
CD5 dtin         real*8      Reciprocal of time step
CD5 dencd        real*8      Intermediate variable in calculation
CD5 mim          int         Current node number
CD5 vap_conc     real*8      Concentration of solute in vapor
CD5 dvap_conc    real*8      Derivative of vap_conc with liquid
CD5                              concentration
CD5 betam1l      real*8      Sorption exponent minus 1
CD5 betam1v      real*8      Sorption exponent minus 1
CD5 danld        real*8      Factor used in calculation
CD5
CD5 Local Subprograms
CD5
CD5 None
CD5
C**********************************************************************
CD6
CD6 FUNCTIONAL DESCRIPTION
CD6
CD6
C**********************************************************************
CD7
CD7 ASSUMPTIONS AND LIMITATIONS
CD7
CD7 It is assumed that upon entry the sorption and reaction parameters
CD7 are properly specified so that no error checks are required to
CD7 catch invalid floating point operations.
CD7
C**********************************************************************
CD8
CD8 SPECIAL COMMENTS
CD8
CD8  Requirements from SDN: 10086-RD-2.20-00
CD8    SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD8    FEHM Application Version 2.20
CD8
C**********************************************************************
CD9
CD9 REQUIREMENTS TRACEABILITY
CD9
CD9 2.3.4 Solute-transport equations
CD9 2.4.5 Adsorbing solutes
CD9
C**********************************************************************
CDA
CDA REFERENCES
CDA
CDA See FEHMN SRS, MMS, and SDD, Robinson's memo EES-4-92-354 for
CDA documentation.
CDA
C**********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN solstore
CPS
CPS   IF a solid species
CPS      Set storage terms
CPS   ELSE  the species is a liquid, vapor
CPS      zero out the other phase
CPS     calculate storage terms
CPS     IF current species is sorbing
CPS       calculate sorption terms
CPS     ENDIF
CPS   ENDIF
CPS
CPS END solstore
CPS
C**********************************************************************

      use comci
      use comdi
      use comrxni
      use comfi
      use comcouple
      use comdti
      use comai
      implicit none

      real*8 dtin
      real*8 dencd
      real*8 vap_conc
      real*8 h_const
      real*8 betam1l
      real*8 betam1v
      real*8 danld
      real*8 dvap_conc
      real*8 conc_subst
      integer mim
      integer mi
      dtin=1./dtotc
      mim=mi-npt(nsp)
      an(mi) = sign(max(abs(an(mi)),1.0d-90),an(mi))
      anl(mi)= sign(max(abs(anl(mi)),1.0d-90),anl(mi))
c      an(mi) = max(1.0d-90,an(mi))
c      anl(mi) = max(1.0d-90,anl(mi))
      if(icns(nsp).eq.0)then
         dencd=anl(mi)*denr(mim)
         denci(mi)=(dencd-dench(mi))*dtin
         akc(mi)=dtin*denr(mim)
         scl(mi) = 0.
         dsccl(mi) = 0.
         scv(mi) = 0.
         dsccv(mi) = 0.
CPS   ELSE the species is a liquid, vapor
      else
CPS   IF a liquid or vapor species
         if(abs(icns(nsp)).eq.1)then
            vap_conc= 0
            dvap_conc = 0
CPS   ELSE current species is a Henry's species
         else
CPS   calculate conc in vapor phase using Henry's Law
            if(henry_model(nsp).eq.1)then
               h_const= a_henry(nsp)*
     2              exp(dh_henry(nsp)/
     3              (gas_const*0.001)*(1/298.16-1/
     4              (t(mim)+temp_conv)))
            elseif(henry_model(nsp).eq.2)then
               h_const = 10**(hawwa(nsp,1)+
     2              hawwa(nsp,2)*(t(mim)+temp_conv)+
     3              hawwa(nsp,3)/(t(mim)+temp_conv)+
     4              hawwa(nsp,4)*dlog10(t(mim)+temp_conv)+
     5              hawwa(nsp,5)/(t(mim)+temp_conv)**2)
               h_const= (101325*rolf(mim)*1e-3)/(h_const*1e6*
     2              mw_water)
            elseif(henry_model(nsp).eq.3)then
               h_const= (phi(mim) - pci(mim)) * dh_henry(nsp)
            endif
            dvap_conc = (mw_water*h_const)/(phi(mim)*avgmolwt(mim))
            vap_conc = anl(mi)*dvap_conc
            anv(mi) = vap_conc
CPS   ENDIF
         endif
CPS   calculate storage terms
         dencd=danl(mi)*ps_trac(mim)*anl(mi)+
     2        danv(mi)*ps_trac(mim)*vap_conc
         akc(mi) = dtin * (danl(mi)*ps_trac(mim) +
     2        danv(mi)*ps_trac(mim)*dvap_conc )
         scl(mi) = 0.
         scv(mi) = 0.
         dsccl(mi) = 0.
         dsccv(mi) = 0.

CPS   IF species is sorbing
         if(iadsfl(nsp,itrc(mi)).ne.0.or.iadsfv(nsp,itrc(mi)).ne.0)then
CPS   calculate sorption terms
            conc_subst = max(anl(mi),1.d-90)
            scl(mi) = (denr(mim) * a1adfl(nsp,itrc(mi)) * conc_subst
     2           **betadfl(nsp,itrc(mi)) / (1.0 +
     3           a2adfl(nsp,itrc(mi)) *
     4           conc_subst**betadfl(nsp,itrc(mi)) ))
            conc_subst = max(vap_conc,1.d-90)
            scv(mi) = (denr(mim) * a1adfv(nsp,itrc(mi)) * conc_subst
     2           **betadfv(nsp,itrc(mi)) / (1.0 + a2adfv(nsp,itrc(mi))
     3           * conc_subst**betadfv(nsp,itrc(mi)) ))
            betam1l = betadfl(nsp,itrc(mi)) - 1
            betam1v = betadfv(nsp,itrc(mi)) - 1
            danld = 1.0
            conc_subst = max(anl(mi),1.d-90)
            dsccl(mi) = denr(mim) * a1adfl(nsp,itrc(mi)) *
     2           betadfl(nsp,itrc(mi)) *
     3           conc_subst**betam1l / ( 1.0 + a2adfl(nsp,itrc(mi)) *
     4           conc_subst**betadfl(nsp,itrc(mi)))**2
            conc_subst = max(vap_conc,1.d-90)
            dsccv(mi) = dvap_conc*
     2           denr(mim)*a1adfv(nsp,itrc(mi))*betadfv(nsp,itrc(mi))*
     3           conc_subst**betam1v/ ( 1.0 +
     4           a2adfv(nsp,itrc(mi)) *
     5           conc_subst**betadfl(nsp,itrc(mi)))**2
            dencd = dencd + scl(mi) + scv(mi)
            akc(mi) = akc(mi) + dtin * ( dsccl(mi) + dsccv(mi) )
CPS   ENDIF
         endif
         denci(mi) = ( dencd - dench(mi) ) * dtin
CPS   ENDIF
      end if
      return
      end


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYEVNW
C...Administers the generation of a high-pT event via calls to
C...a number of subroutines for the new multiple interactions and
C...showering framework.

      SUBROUTINE PYEVNW

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYCOMP
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      include 'inc/pypart'
C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pyctag'
      include 'inc/pydat1'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint4'
      include 'inc/pyint5'
      include 'inc/pyintm'

C...Local arrays.
      DIMENSION VTX(4)

C...Stop if no subprocesses on.
      IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
        WRITE(MSTU(11),5100)
        CALL PYSTOP(1)
      ENDIF

C...Initial values for some counters.
      MSTU(1)=0
      MSTU(2)=0
      N=0
      MINT(5)=MINT(5)+1
      MINT(7)=0
      MINT(8)=0
      MINT(30)=0
      MINT(83)=0
      MINT(84)=MSTP(126)
      MSTU(24)=0
      MSTU70=0
      MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCT/.
      NCT=0
      MINT(33)=0
C...Zero counters for pT-ordered showers (failsafe)
      NPART=0
      NPARTD=0

C...Let called routines know call is from PYEVNW (not PYEVNT).
      MINT(35)=3

C...If variable energies: redo incoming kinematics and cross-section.
      MSTI(61)=0
      IF(MSTP(171).EQ.1) THEN
        CALL PYINKI(1)
        IF(MSTI(61).EQ.1) THEN
          MINT(5)=MINT(5)-1
          RETURN
        ENDIF
        IF(MINT(121).GT.1) CALL PYSAVE(3,1)
        CALL PYXTOT
      ENDIF

C...Loop over number of pileup events; check space left.
      IF(MSTP(131).LE.0) THEN
        NPILE=1
      ELSE
        CALL PYPILE(2)
        NPILE=MINT(81)
      ENDIF
      DO 300 IPILE=1,NPILE
        IF(MINT(84)+100.GE.MSTU(4)) THEN
          CALL PYERRM(11,
     &    '(PYEVNW:) no more space in PYJETS for pileup events')
          IF(MSTU(21).GE.1) GOTO 310
        ENDIF
        MINT(82)=IPILE

C...Generate variables of hard scattering.
        MINT(51)=0
        MSTI(52)=0
        LOOPHS  =0
  100   CONTINUE
        LOOPHS  = LOOPHS + 1
        IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
        IF(LOOPHS.GE.10) THEN
          CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
     &        //'multiple interactions. Returning.')
          MINT(51)=1
          RETURN
        ENDIF
        MINT(31)=0
        MINT(39)=0
        MINT(36)=0
        MINT(51)=0
        MINT(57)=0
        CALL PYRAND
        IF(MSTI(61).EQ.1) THEN
          MINT(5)=MINT(5)-1
          RETURN
        ENDIF
        IF(MINT(51).EQ.2) RETURN
        ISUB=MINT(1)
        IF(MSTP(111).EQ.-1) GOTO 290

C...Loopback point if PYPREP fails, especially for junction topologies.
        NPREP=0
        MNT31S=MINT(31)
  110   NPREP=NPREP+1
        MINT(31)=MNT31S

        IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
C...Hard scattering (including low-pT):
C...reconstruct kinematics and colour flow of hard scattering.
          MINT31=MINT(31)
  120     MINT(31)=MINT31
          MINT(51)=0
          CALL PYSCAT
          IF(MINT(51).EQ.1) GOTO 100
          NPARTD=N
          NFIN=N

C...Intertwined initial state showers and multiple interactions.
C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
          MSTP61=MSTP(61)
          IF (MINT(47).LT.2) MSTP(61)=0
          MSTP81=MSTP(81)
          IF (MINT(50).EQ.0) MSTP(81)=0
          IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
     &    MINT(111).NE.12) THEN
C...Absolute max pT2 scale for evolution: phase space limit.
            PT2MXS=0.25D0*VINT(2)
C...Check if more constrained by ISR and MI max scales:
            PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62)))
C...Loopback point in case of failure in evolution.
            LOOP=0
  130       LOOP=LOOP+1
            MINT(51)=0
            IF(LOOP.GT.100) THEN
              CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
     &             //'multiple interactions. Trying new point.')
              MINT(51)=1
              RETURN
            ENDIF

C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
C...once per event. (E.g. compute constants and save variables to be
C...restored later in case of failure.)
            IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)

C...Initialize interleaved MI/ISR/JI evolution.
C...PT2MAX: absolute upper limit for evolution - Initialization may
C...        return a PT2MAX which is lower than this.
C...PT2MIN: absolute lower limit for evolution - Initialization may
C...        return a PT2MIN which is larger than this (e.g. Lambda_QCD).
            PT2MAX=PT2MXS
            PT2MIN=0D0
            CALL PYEVOL(0,PT2MAX,PT2MIN)
C...If failed to initialize evolution, generate a new hard process
            IF (MINT(51).EQ.1) GOTO 100

C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
C...In principle factorized, so can be stopped and restarted.
C...Example: stop/start at pT=10 GeV. (Commented out for now.)
C            PT2MED=MAX(10D0**2,PT2MIN)
C            CALL PYEVOL(1,PT2MAX,PT2MED)
C            IF (MINT(51).EQ.1) GOTO 160
C            PT2MAX=PT2MED
            CALL PYEVOL(1,PT2MAX,PT2MIN)
C...If fatal error (e.g., massive hard-process initiator, but no available
C...phase space for creation), generate a new hard process
            IF (MINT(51).EQ.2) GOTO 100
C...If smaller error, just try running evolution again
            IF (MINT(51).EQ.1) GOTO 130

C...Finalize interleaved MI/ISR/JI evolution.
            CALL PYEVOL(2,PT2MAX,PT2MIN)
            IF (MINT(51).EQ.1) GOTO 130

          ENDIF
          MSTP(61)=MSTP61
          MSTP(81)=MSTP81
          IF(MINT(51).EQ.1) GOTO 100
C...(MINT(52) is actually obsolete in this routine. Set anyway
C...to ensure PYDOCU stable.)
          MINT(52)=N
          MINT(53)=N

C...Beam remnants - new scheme.
          IF(MINT(50).EQ.1) THEN
            IF (ISUB.EQ.95) MINT(31)=1

C...Beam remnant flavour and colour assignments - new scheme.
            CALL PYMIHK
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &           GOTO 120
            IF(MINT(51).EQ.1) GOTO 100

C...Primordial kT and beam remnant momentum sharing - new scheme.
            CALL PYMIRM
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &      GOTO 120
            IF(MINT(51).EQ.1) GOTO 100
            IF (ISUB.EQ.95) MINT(31)=0
          ELSEIF(MINT(111).NE.12) THEN
C...Hadron remnants and primordial kT - old model.
C...Happens e.g. for direct photon on one side.
            IPU1=IMI(1,1,1)
            IPU2=IMI(2,1,1)
            CALL PYREMN(IPU1,IPU2)
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
     &           110
            IF(MINT(51).EQ.1) GOTO 100
C...PYREMN does not set colour tags for BRs, so needs to be done now.
            DO 160 I=MINT(53)+1,N
              DO 150 KCS=4,5
                IDA=MOD(K(I,KCS),MSTU(5))
                IF (IDA.NE.0) THEN
                  MCT(I,KCS-3)=MCT(IDA,6-KCS)
                ELSE
                  MCT(I,KCS-3)=0
                ENDIF
  150         CONTINUE
  160       CONTINUE
C...Instruct PYPREP to use colour tags
            MINT(33)=1

            DO 360 MQGST=1,2
              DO 350 I=MINT(84)+1,N

C...Look for coloured string endpoint, or (later) leftover gluon.
                IF (K(I,1).NE.3) GOTO 350
                KC=PYCOMP(K(I,2))
                IF(KC.EQ.0) GOTO 350
                KQ=KCHG(KC,2)
                IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350

C...  Pick up loose string end with no previous tag.
                KCS=4
                IF(KQ*SIGN(1,K(I,2)).LT.0) KCS=5
                IF(MCT(I,KCS-3).NE.0) GOTO 350

                CALL PYCTTR(I,KCS,I)
                IF(MINT(51).NE.0) RETURN

 350          CONTINUE
 360        CONTINUE
C...Now delete any colour processing information if set (since partons
C...otherwise not FS showered!)
            DO 170 I=MINT(84)+1,N
              IF (I.LE.N) THEN
                K(I,4)=MOD(K(I,4),MSTU(5)**2)
                K(I,5)=MOD(K(I,5),MSTU(5)**2)
              ENDIF
  170       CONTINUE
          ENDIF

C...Showering of final state partons (optional).
          ALAMSV=PARJ(81)
          PARJ(81)=PARP(72)
          IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
     &    THEN
            QMAX=VINT(55)
            IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
            CALL PYPTFS(1,QMAX,0D0,PTGEN)
C...External processes: handle successive showers.
          ELSEIF(ISET(ISUB).EQ.11) THEN
            CALL PYADSH(NFIN)
          ENDIF
          PARJ(81)=ALAMSV

C...Allow possibility for user to abort event generation.
          IVETO=0
          IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
          IF(IVETO.EQ.1) THEN
C...........No reason to count this as an error
            LOOPHS = LOOPHS-1
            GOTO 100
          ENDIF

C...Decay of final state resonances.
          MINT(32)=0
          IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
            CALL PYRESD(0)
            IF(MINT(51).NE.0) GOTO 100
          ENDIF

          IF(MINT(51).EQ.1) GOTO 100

        ELSEIF(ISUB.NE.99) THEN
C...Diffractive and elastic scattering.
          CALL PYDIFF

        ELSE
C...DIS scattering (photon flux external).
          CALL PYDISG
          IF(MINT(51).EQ.1) GOTO 100
        ENDIF

C...Check that no odd resonance left undecayed.
        MINT(54)=N
        IF(MSTP(111).GE.1) THEN
          NFIX=N
          DO 180 I=MINT(84)+1,NFIX
            IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
     &      K(I,2).NE.22) THEN
              KCA=PYCOMP(K(I,2))
              IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
                CALL PYRESD(I)
                IF(MINT(51).EQ.1) GOTO 100
              ENDIF
            ENDIF
  180     CONTINUE
        ENDIF

C...Boost hadronic subsystem to overall rest frame.
C..(Only relevant when photon inside lepton beam.)
        IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)

C...Recalculate energies from momenta and masses (if desired).
        IF(MSTP(113).GE.1) THEN
          DO 190 I=MINT(83)+1,N
            IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
     &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
  190     CONTINUE
          NRECAL=N
        ENDIF

C...Colour reconnection before string formation
        CALL PYFSCR(MINT(84)+1)

C...Rearrange partons along strings, check invariant mass cuts.
        MSTU(28)=0
        IF(MSTP(111).LE.0) MSTJ(14)=-1
        CALL PYPREP(MINT(84)+1)
        MSTJ(14)=MSTJ14
        IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
          MSTU(24)=0
          GOTO 100
        ENDIF
        IF(MINT(51).EQ.1) GOTO 110
        IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
        IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
          DO 220 I=MINT(84)+1,N
            IF(K(I,2).EQ.94) THEN
              DO 210 I1=I+1,MIN(N,I+10)
                IF(K(I1,3).EQ.I) THEN
                  K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
                  IF(K(I1,3).EQ.0) THEN
                    DO 200 II=MINT(84)+1,I-1
                        IF(K(II,2).EQ.K(I1,2)) THEN
                          IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
     &                    MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
                        ENDIF
  200               CONTINUE
                    IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
                  ENDIF
                ENDIF
  210         CONTINUE
C...Also collapse particles decaying to themselves (if same KS)
C...Sep 22 2009: Commented out by PS following suggestion by TS to fix
C...problem with history point-backs in new shower, where a particle is
C...copied with a new momentum when it is the recoiler.
C            ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
C     &            .AND.K(I,4).LT.N) THEN
C              IDA=K(I,4)
C              IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
C                K(I,1)=0
C              ENDIF
            ENDIF
  220     CONTINUE
          CALL PYEDIT(12)
          CALL PYEDIT(14)
          IF(MSTP(125).EQ.0) CALL PYEDIT(15)
          IF(MSTP(125).EQ.0) MINT(4)=0
          DO 240 I=MINT(83)+1,N
            IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
              DO 230 I1=I+1,N
                IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
                IF(K(I1,3).EQ.I) K(I,5)=I1
  230         CONTINUE
            ENDIF
  240     CONTINUE
        ENDIF

C...Introduce separators between sections in PYLIST event listing.
        IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
          MSTU70=1
          MSTU(71)=N
        ELSEIF(IPILE.EQ.1) THEN
          MSTU70=3
          MSTU(71)=2
          MSTU(72)=MINT(4)
          MSTU(73)=N
        ENDIF

C...Go back to lab frame (needed for vertices, also in fragmentation).
        CALL PYFRAM(1)

C...Set nonvanishing production vertex (optional).
        IF(MSTP(151).EQ.1) THEN
          DO 250 J=1,4
            VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
     &      SIN(PARU(2)*PYR(0))
  250     CONTINUE
          DO 270 I=MINT(83)+1,N
            DO 260 J=1,4
              V(I,J)=V(I,J)+VTX(J)
  260       CONTINUE
  270     CONTINUE
        ENDIF

C...Perform hadronization (if desired).
        IF(MSTP(111).GE.1) THEN
          CALL PYEXEC
          IF(MSTU(24).NE.0) GOTO 100
        ENDIF
        IF(MSTP(113).GE.1) THEN
          DO 280 I=NRECAL,N
            IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
     &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
  280     CONTINUE
        ENDIF
        IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)

C...Store event information and calculate Monte Carlo estimates of
C...subprocess cross-sections.
  290   IF(IPILE.EQ.1) CALL PYDOCU

C...Set counters for current pileup event and loop to next one.
        MSTI(41)=IPILE
        IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
        IF(MSTU70.LT.10) THEN
          MSTU70=MSTU70+1
          MSTU(70+MSTU70)=N
        ENDIF
        MINT(83)=N
        MINT(84)=N+MSTP(126)
        IF(IPILE.LT.NPILE) CALL PYFRAM(2)
  300 CONTINUE

C...Generic information on pileup events. Reconstruct missing history.
      IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
        PARI(91)=VINT(132)
        PARI(92)=VINT(133)
        PARI(93)=VINT(134)
        IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
      ENDIF
      CALL PYEDIT(16)

C...Transform to the desired coordinate frame.
  310 CALL PYFRAM(MSTP(124))
      MSTU(70)=MSTU70
      PARU(21)=VINT(1)

C...Error messages
 5100 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')

      RETURN
      END