      PROGRAM MAIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES/NOLIST'
      COMMON /KEYWRD/ KEYWRD
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), XPARAM(MAXPAR)
      COMMON /GEOSYM/ NDEP,LOCPAR(200),IDEPFN(200),LOCDEP(200)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     +NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /GMETRY/ GEO(3,NUMATM)
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM
      COMMON /NUMCAL/ NUMCAL
      COMMON /TIME  / TIME0
      COMMON /PATH  / LATOM,LPARAM,REACT(100)
      CHARACTER*80 KEYWRD
      NUMCAL=1
C
      TIME0=SECOND()
C
C READ AND CHECK INPUT FILE, EXIT IF NECESSARY.
C     WRITE INPUT FILE TO UNIT 6 AS FEEDBACK TO USER
C
   5  CALL READ
C
C INITIALIZE CALCULATION AND WRITE CALCULATION INDEPENDENT INFO
C
      CALL MOLDAT
C
C CALCULATE
C
C
      IF(INDEX(KEYWRD,'SADDLE') .NE. 0) THEN
          CALL REACT1(FUNCT)
          CALL WRITE(TIME0,FUNCT)
          STOP
      ENDIF
      IF (LATOM .NE. 0) THEN
C
C       DO PATH
C
         CALL PATHS
         STOP
      END IF
      IF (INDEX(KEYWRD,'FORCE') .NE. 0 ) THEN
C
C FORCE CALCULATION IF DESIRED
C
         CALL FORCE
         STOP
      ENDIF
C
      IF(INDEX(KEYWRD,'NLLSQ') .NE. 0) THEN
         CALL NLLSQ(XPARAM, NVAR )
         CALL COMPFG(XPARAM,.TRUE.,ESCF,.TRUE.,GRAD,.TRUE.)
         CALL WRITE(TIME0,ESCF)
      STOP
      ENDIF
C
      IF (INDEX(KEYWRD,'1SCF') .NE. 0) THEN
            NVAR=0
      IF(INDEX(KEYWRD,'GRAD').NE.0) THEN
      NVAR=0
      DO 10 I=2,NATOMS
          IF(LABELS(I).EQ.99) GOTO 10
          IF(I.EQ.2)ILIM=1
          IF(I.EQ.3)ILIM=2
          IF(I.GT.3)ILIM=3
          DO 13 J=1,ILIM
              NVAR=NVAR+1
              LOC(1,NVAR)=I
              LOC(2,NVAR)=J
13            XPARAM(NVAR)=GEO(J,I)
10    CONTINUE
            ENDIF
      ENDIF
      IF(INDEX(KEYWRD,'SIGMA') .NE. 0) THEN
         CALL POWSQ(XPARAM, NVAR, ESCF)
         CALL WRITE(TIME0,ESCF)
         STOP
      ENDIF
C
C ORDINARY GEOMETRY OPTIMISATION
C
         CALL FLEPO(XPARAM, NVAR, ESCF)
         CALL WRITE(TIME0,ESCF)
      STOP
      END
C
C
      BLOCK DATA
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /NATORB/ NATORB(54)
     +       /ALPHA / ALP(54)
     1       /CORE  / CORE(54)
     2       /MULTIP/ DD(54),QQ(54),AM(54),AD(54),AQ(54)
     3       /EXPONT/ ZS(54),ZP(54),ZD(54)
     4       /ONELEC/ USS(54),UPP(54),UDD(54)
     5       /BETAS / BETAS(54),BETAP(54),BETAD(54)
     6       /TWOELE/ GSS(54),GSP(54),GPP(54),GP2(54),HSP(54)
     7       /ATOMIC/ EISOL(54),EHEAT(54)
     8       /AM1REF/ AM1REF(54)
     9       /VSIPS / VS(54),VP(54),VD(54)
     A       /ISTOPE/ AMS(54)
*
*  COMMON BLOCKS FOR MINDO/3
*
      COMMON /ONELE3 /  USS3(18),UPP3(18)
     +       /TWOEL3 /  F03(18)
     1       /ATOMI3 /  EISOL3(18),EHEAT3(18)
     2       /BETA3  /  BETA3(153)
     3       /ALPHA3 /  ALP3(153)
     4       /EXPON3 /  ZS3(18),ZP3(18)
*
*  END OF MINDO/3 COMMON BLOCKS
*

C
C   NATORB IS THE NUMBER OF ATOMIC ORBITALS PER ATOM.
C
      DATA NATORB/2*1,8*4,8*4,2*4,10*9,6*4,2*4,10*9,6*4/
      DATA AM1REF /54*1.D0/
C
C   THE ATOMIC MASSES OF THE ISOTOPES
      DATA  AMS(1) / 1.007825D0/
      DATA  AMS(4) / 9.012190D0/
      DATA  AMS(5) / 11.00931D0/
      DATA  AMS(6) / 12.00000D0/
      DATA  AMS(7) / 14.00307D0/
      DATA  AMS(8) / 15.99491D0/
      DATA  AMS(9) / 18.99840D0/
      DATA  AMS(13)/ 26.98153D0/
      DATA  AMS(14)/ 27.97693D0/
      DATA  AMS(15)/ 30.97376D0/
      DATA  AMS(16)/ 31.97207D0/
      DATA  AMS(17)/ 34.96885D0 /
      DATA  AMS(35)/ 79.9D0 /
      DATA  AMS(53)/ 126.9D0 /
C   ATOMIC WEIGHTS FOR LESS ABUNDANT ISOTOPES:
C                  AMS(2) = DEUTERIUM
C                  AMS(3) = CARBON 13
C                  AMS(10)= CARBON 14
C                  AMS(11)= OXYGEN 18
C                  AMS(12)= BORON 10
      DATA  AMS(2) /2.0141022D0/
      DATA  AMS(3) /13.003354D0/
      DATA  AMS(10)/14.003242D0/
      DATA  AMS(11)/17.999160D0/
      DATA  AMS(12)/10.012940D0/
C
C   CORE IS THE CHARGE ON THE ATOM AS SEEN BY THE ELECTRONS
C
      DATA CORE(1),CORE(4) /1.0D00,  2.D0/
      DATA CORE(5)/3.0D00/
      DATA CORE(6)/4.0D00/
      DATA CORE(7)/5.0D00/
      DATA CORE(8)/6.0D00/
      DATA CORE(9)/7.0D00/
      DATA CORE(13)/3.0D00/
      DATA CORE(14)/4.0D00/
      DATA CORE(15)/5.0D00/
      DATA CORE(16)/6.0D00/
      DATA CORE(17)/7.0D00/
      DATA CORE(35)/7.D0/
      DATA CORE(53)/7.D0/
C
C     ENTHALPIES OF FORMATION OF GASEOUS ATOMS ARE TAKEN FROM \ANNUAL
C     REPORTS,1974,71B,P 117\  THERE ARE SOME SIGNIFICANT DIFFERENCES
C     BETWEEN THE VALUES REPORTED THERE AND THE VALUES PREVIOUSLY IN
C     THE BLOCK DATA OF THIS PROGRAM.  ONLY THE THIRD  ROW ELEMENTS
C     HAVE BEEN UPDATED.
C
      DATA EHEAT(1),EHEAT(4) /52.102D00 , 76.96D00 /
      DATA EHEAT(5)/135.7D00/
      DATA EHEAT(6) / 170.89D00 /
      DATA EHEAT(7)/113.0D00/
      DATA EHEAT(8)/59.559D00/
      DATA EHEAT(9)/18.89D00/
      DATA EHEAT(13)/79.49D00/
      DATA EHEAT(14)/108.39D00/
      DATA EHEAT(15)/75.57D00/
      DATA EHEAT(16)/66.40D00/
      DATA EHEAT(17)/28.99D00/
      DATA EHEAT(35)/26.74D0/
      DATA EHEAT(53)/25.517D0/
C *** VS AND VP ARE THE VALENCE STATE IONIZATION POTENTAIL OF S AND P
C     ELECTRONS IN E.V. : USED IN THE EHT RESONANCE INTEGRALS.
C
      DATA VS(1) /  -13.605  /
      DATA VS(5)/-15.16D00/
      DATA VS(6)/-21.34D00/
      DATA VS(7)/-27.51D00/
      DATA VS(8)/-35.30D00/
      DATA VS(9)/-43.70D00/
      DATA VS(14)/-17.82D00/
      DATA VS(15)/-21.10D00/
      DATA VS(16)/-23.84D00/
      DATA VS(17)/-25.26D00/
      DATA VP(1)  /  0.0D00  /
      DATA VP(5)/-8.52D00/
      DATA VP(6)/-11.54D00/
      DATA VP(7)/-14.34D00/
      DATA VP(8)/-17.91D00/
      DATA VP(9)/-20.89D00/
      DATA VP(14)/-8.51D00/
      DATA VP(15)/-10.29D00/
      DATA VP(16)/-12.41D00/
      DATA VP(17)/-15.09D00/
C      DATA NPQ/1,1, 2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3, 4,4,4,4,4,4,4,4,
C     +4,4,4,4,4,4,4,4,4,4, 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5/
C
C *** ONE CENTER REPULSION INTEGRALS
C     GSS ::= (SS,SS)
C     GPP ::= (PP,PP)
C     GSP ::= (SS,PP)
C     GP2 ::= (PP,P*P*)
C     HSP ::= (SP,SP)
      DATA GSS(1) / 12.848D00 /
      DATA GSS(4)/9.00D00/
      DATA GSS(5)/10.59D00/
      DATA GSS(6) / 12.23D00 /
      DATA GSS(7)/13.59D00/
      DATA GSS(8)/15.42D00/
      DATA GSS(9)/16.92D00/
      DATA GSS(13)/8.09D00/
      DATA GSS(14)/9.82D00/
      DATA GSS(15)/11.56D00/
      DATA GSS(16)/12.88D00/
      DATA GSS(17)/15.03D00/
      DATA GSS(35)/15.03643948D0/
      DATA GSS(53)/15.04044855D0/
      DATA GPP(4)/6.97D00/
      DATA GPP(5)/8.86D00/
      DATA GPP(6) / 11.08D00 /
      DATA GPP(7)/12.98D00/
      DATA GPP(8)/14.52D00/
      DATA GPP(9)/16.71D00/
      DATA GPP(13)/5.98D00/
      DATA GPP(14)/7.31D00/
      DATA GPP(15)/8.64D00/
      DATA GPP(16)/9.90D00/
      DATA GPP(17)/11.30D00/
      DATA GPP(35)/11.27632539D0/
      DATA GPP(53)/11.14778369D0/
      DATA GSP(4)/7.43D00/
      DATA GSP(5)/9.56D00/
      DATA GSP(6) / 11.47D00 /
      DATA GSP(7)/12.66D00/
      DATA GSP(8)/14.48D00/
      DATA GSP(9)/17.25D00/
      DATA GSP(13)/6.63D00/
      DATA GSP(14)/8.36D00/
      DATA GSP(15)/10.08D00/
      DATA GSP(16)/11.26D00/
      DATA GSP(17)/13.16D00/
      DATA GSP(35)/13.03468242D0/
      DATA GSP(53)/13.05655798D0/
      DATA GP2(4)/6.22D00/
      DATA GP2(5)/7.86D00/
      DATA GP2(6) / 9.84D00 /
      DATA GP2(7)/11.59D00/
      DATA GP2(8)/12.98D00/
      DATA GP2(9)/14.91D00/
      DATA GP2(13)/5.40D00/
      DATA GP2(14)/6.54D00/
      DATA GP2(15)/7.68D00/
      DATA GP2(16)/8.83D00/
      DATA GP2(17)/9.97D00/
      DATA GP2(35)/9.85442552D0/
      DATA GP2(53)/9.91409071D0/
      DATA HSP(4)/1.28D00/
      DATA HSP(5)/1.81D00/
      DATA HSP(6) / 2.43D00 /
      DATA HSP(7)/3.14D00/
      DATA HSP(8)/3.94D00/
      DATA HSP(9)/4.83D00/
      DATA HSP(13)/0.70D00/
      DATA HSP(14)/1.32D00/
      DATA HSP(15)/1.92D00/
      DATA HSP(16)/2.26D00/
      DATA HSP(17)/2.42D00/
      DATA HSP(35)/2.45586832D0/
      DATA HSP(53)/2.45638202D0/
C
C     THE MONOCENTRIC INTEGRALS HSP AND GSP FOR ALUMINIUM ARE ONLY
C     ESTIMATES. A VALUE OF G1 FOR AL IS NEEDED TO RESOLVE OLEARIS
C     INTEGRALS.
C
C     OPTIMIZED MNDO PARAMETERS FOR H, BE, B, C, N, O, F
C                                                     CL
C     ESTIMATED MNDO PARAMETERS FOR       AL,SI, P, S
C
C     ELEMENTS H, C, N, O WERE PARAMETERIZED BY WALTER THIEL
C     ELEMENTS B,SI,P,S   WERE      ..          MICHAEL MCKEE
C     ELEMENTS BE,F,AL,CL WERE      ..          HENRY RZEPA
C
      DATA USS(1)/-11.906276D00/
      DATA USS(4)/-16.602378D00/
      DATA USS(5)/-34.547130D00/
      DATA USS(6)/-52.279745D00/
      DATA USS(7)/ -71.932122D00/
      DATA USS(8)/-99.644309D00/
      DATA USS(9)/-131.071548D00/
      DATA USS(13)/-23.807097D00/
      DATA USS(14)/-40.568292D00/
      DATA USS(15)/-56.143360D00/
      DATA USS(16)/-75.239152D00/
      DATA USS(17)/-100.227166D00/
      DATA USS(35)/ -99.98644054D0/
      DATA USS(53)/-100.00305378D0/
      DATA UPP(4)/-10.703771D00/
      DATA UPP(5)/-23.121690D00/
      DATA UPP(6)/-39.205558D00/
      DATA UPP(7)/-57.172319D00/
      DATA UPP(8)/-77.797472D00/
      DATA UPP(9)/-105.782137D00/
      DATA UPP(13)/-17.519878D00/
      DATA UPP(14)/-28.089187D00/
      DATA UPP(15)/-42.851080D00/
      DATA UPP(16)/-57.832013D00/
      DATA UPP(17)/-77.378667D00/
      DATA UPP(35)/-75.67130754D0/
      DATA UPP(53)/-74.61146919D0/
C
C     OPTIMIZED ORBITAL EXPONENTS (DEFAULT = CLEMENTI + 0.3)
C
      DATA ZS(1),ZP(1)/1.331967D00 , 0.0D00/
      DATA ZS(4),  ZP(4)   /           1.004210D0,  1.004210D0  /
      DATA ZS(5),  ZP(5)   /           1.506801D0,  1.506801D0  /
      DATA ZS(6),ZP(6) / 1.787537D00 , 1.787537D00 /
      DATA ZS(7),  ZP(7)   /           2.255614D0,  2.255614D0  /
      DATA ZS(8),  ZP(8)   /           2.699905D0,  2.699905D0  /
      DATA ZS(9),  ZP(9)   /           2.848487D0,  2.848487D0  /
      DATA ZS(13), ZP(13)  /           1.444161D0,  1.444161D0  /
      DATA ZS(14), ZP(14)  /           1.435306D0,  1.435306D0  /
      DATA ZS(15), ZP(15)  /           2.108720D0,  1.785810D0  /
      DATA ZS(16), ZP(16)  /           2.613591D0,  2.034393D0  /
      DATA ZS(17), ZP(17)  /           3.784645D0,  2.036263D00 /
      DATA ZS(35), ZP(35)  /           3.85430190D0,2.19920914D0/
      DATA ZS(53), ZP(53)  /           2.2729610D0, 2.16949803D0/
      DATA ZD/10*0.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,36*1.D0/
C     TWO CENTRE RESONANCE INTEGRALS AND CORE-CORE REPULSION FUNCTIONS
C
      DATA BETAS(1)/    -6.989064D0 /
      DATA BETAS(4)/    -4.017096D0 /
      DATA BETAS(5)/    -8.252054D0 /
      DATA BETAS(6)/   -18.985044D0 /
      DATA BETAS(7)/   -20.495758D0 /
      DATA BETAS(8)/   -32.688082D0 /
      DATA BETAS(9)/   -48.290466D0 /
      DATA BETAS(13)/   -2.670284D0 /
      DATA BETAS(14)/   -4.256218D0 /
      DATA BETAS(15)/   -6.791600D0 /
      DATA BETAS(16)/  -11.142231D0 /
      DATA BETAS(17)/  -14.262320D0 /
      DATA BETAS(35)/   -8.917107D0 /
      DATA BETAS(53)/   -7.414451D0 /
      DATA BETAP(4)/    -4.017096D0 /
      DATA BETAP(5)/    -8.252054D0 /
      DATA BETAP(6)/    -7.934122D0 /
      DATA BETAP(7)/   -20.495758D0 /
      DATA BETAP(8)/   -32.688082D0 /
      DATA BETAP(9)/   -36.508540D0 /
      DATA BETAP(13)/   -2.670284D0 /
      DATA BETAP(14)/   -4.256218D0 /
      DATA BETAP(15)/   -6.791600D0 /
      DATA BETAP(16)/  -11.142231D0 /
      DATA BETAP(17)/  -14.262320D0 /
      DATA BETAP(35)/   -9.943740D0 /
      DATA BETAP(53)/   -6.196781D0 /
      DATA ALP(1) / 2.5441341D00/
      DATA ALP(4)/          1.669434D0/
      DATA ALP(5)/           2.134993D0/
      DATA ALP(6) / 2.546380D00 /
      DATA ALP(7)/           2.861342D0/
      DATA ALP(8)/           3.160604D0/
      DATA ALP(9)/           3.4196606D0/
      DATA ALP(13)/          1.8688394D0/
      DATA ALP(14)/           2.1961078D0/
      DATA ALP(15)/           2.4152800D0/
      DATA ALP(16)/           2.4916445D0/
      DATA ALP(17)/           2.542201D0/
      DATA ALP(35)/           2.44570512D0/
      DATA ALP(53)/           2.2073200D0/
C
C     ELECTRONIC ENERGIES OF NEUTRAL FREE ATOMS
C
      DATA EISOL(1) / -11.906276D00 /
      DATA EISOL(4)/          -24.204740D0/
      DATA EISOL(5)/           -64.315950D0/
      DATA EISOL(6) / -120.500606D00 /
      DATA EISOL(7)/           -202.581201D0/
      DATA EISOL(8)/           -317.868506D0/
      DATA EISOL(9)/           -476.683781D0/
      DATA EISOL(13)/          -44.4840711D0/
      DATA EISOL(14)/           -90.53496D0/
      DATA EISOL(15)/           -152.959960D0/
      DATA EISOL(16)/           -235.45636D0/
      DATA EISOL(17)/           -353.137667D0/
      DATA EISOL(35)/           -346.681250D0/
      DATA EISOL(53)/           -340.59836D00/
C
C     DIPOLE AND QUADRUPOLE CHARGE SEPARATIONS.
C
      DATA DD(4), QQ(4) /              1.43732454D0, 1.21961031D0 /
      DATA DD(5), QQ(5) /              0.95790730D0, 0.81281129D0 /
      DATA DD(6),QQ(6) / .80746618D00 , .68515777D00 /
      DATA DD(7), QQ(7) /              0.63990367D0, 0.54297627D0 /
      DATA DD(8), QQ(8) /              0.53460239D0, 0.45362517D0 /
      DATA DD(9), QQ(9) /              0.50671661D0, 0.42996330D0 /
      DATA DD(13),QQ(13)/              1.39923869D0, 1.15867971D0 /
      DATA DD(14),QQ(14)/              1.40787117D0, 1.16582809D0 /
      DATA DD(15),QQ(15)/              1.01296990D0, 0.93700901D0 /
      DATA DD(16),QQ(16)/              0.82315963D0, 0.82251564D0 /
      DATA DD(17),QQ(17)/              0.49868702D0, 0.82176028D0 /
      DATA DD(35),QQ(35)/              0.6051074D0,  0.9645873D0  /
      DATA DD(53),QQ(53)/              1.4253233D0,  1.1841707D0  /
C
C     ADDITIVE TERMS( STORED AS A LINEAR ARRAY FOR COMPATIBILITY)
C
      DATA AM(1),AD(1),AQ(1)/ 0.47217935D0,0.47217935D0,0.00000000D0/
      DATA AM(4),AD(4),AQ(4)/ 0.33076075D0,0.33561420D0,0.38629372D0/
      DATA AM(5),AD(5),AQ(5)/ 0.38919515D0,0.49047299D0,0.55569787D0/
      DATA AM(6),AD(6),AQ(6)/ 0.44946711D0,0.61494736D0,0.66858974D0/
      DATA AM(7),AD(7),AQ(7)/0.49944873D0,0.78436428D0,0.81447199D0/
      DATA AM(8),AD(8),AQ(8)/ 0.56670342D0,0.95925620D0,0.94959338D0/
      DATA AM(9),AD(9),AQ(9)/ 0.62183021D0,1.08503007D0,1.03436433D0/
      DATA AM(13),AD(13),AQ(13)/0.29731716D0,0.26355743D0,0.36735599D0/
      DATA AM(14),AD(14),AQ(14)/0.36089673D0,0.34418174D0,0.39826149D0/
      DATA AM(15),AD(15),AQ(15)/0.42484381D0,0.48824197D0,0.49794058D0/
      DATA AM(16),AD(16),AQ(16)/0.47335538D0,0.58893950D0,0.56496234D0/
      DATA AM(17),AD(17),AQ(17)/0.55237045D0,0.80612202D0,0.60686609D0/
      DATA AM(35),AD(35),AQ(35)/0.5526068D0, 0.7258330D0, 0.5574589D0 /
      DATA AM(53),AD(53),AQ(53)/0.5527541D0, 0.4593451D0, 0.4585376D0 /
*
*
*   ALL THE FOLLOWING DATA APPLY TO MINDO/3 AND NOT TO MNDO
*
*
*

C *** F03 IS THE ONE CENTER AVERAGED REPULSION INTEGRAL FOR USE IN THE
C        TWO CENTER ELECTRONIC REPULSION INTEGRAL EVALUATION.

      DATA F03              /  12.848D0, 0.0D0, 0.0D0, 0.0D0,
     .  8.958D0, 10.833D0, 12.377D0, 13.985D0, 16.250D0,
     .         0.000D0, 0.000D0, 0.000D0, 0.000D0,
     .    7.57D0 ,  9.00D0 , 10.20D0 , 11.73,.0D0/

C *** USS AND UPP ARE THE ONE-CENTER CORE ELECTRON ATTRACTION AND KINETI
C     ENERGY INTEGRALS FOR S AND P ELECTRONS RESPECTIVELY IN E.V.

      DATA USS3             / -12.505D0, 0.000D0, 0.000D0, 0.000D0,
     .                       -33.61D0, -51.79D0, -66.06D0, -91.73D0 ,
     .                       -129.86D0,
     .                        0.0000D0 , 0.000 D0 ,0.000D0 , 0.000D0 ,
     .          -39.82D0 , -56.23D0 , -73.39D0 , -98.99D0 ,.0D0/
      DATA UPP3             /   0.0D0, 0.0D0, 0.0D0, 0.0D0,
     .     -25.11D0 , -39.18D0 , -56.40D0 , -78.80D0 , -105.93D0 ,
     .                        0.000D0 , 0.000D0 , 0.000D0 , 0.000D0 ,
     .         -29.15D0 , -42.31D0 , -57.25D0 , -76.43D0 ,.0D0/

C *** EISOL3 AND EHEAT3 ARE THE GS ELECTRONIC ENERGY OF THE NEUTRAL ATOM
C     (IN E.V.) AND THE HEAT OF FORMATION IF THE FREE ATOM (IN KCAL/MOL)

      DATA EISOL3             /-12.505D0 , 0.0D0 , 0.0D0 ,0.0D0 ,
     .        -61.70D0 ,-119.47D0 , -187.51D0 , -307.07D0 , -475.00D0 ,
     .                         0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,
     .          -90.98D0 , -150.81D0 , -229.15D0 , -345.93D0 , 0.0D0/
      DATA EHEAT3             / 52.102D0 , 0.0D0 , 0.0D0 , 0.0D0 ,
     .     135.7 D0 , 170.89D0 ,  113.0 D0 ,  59.559D0 ,  18.86D0 ,
     .                         0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 ,
     .     106.0D0 ,   79.8D0 ,  65.65D0 ,  28.95D0 , 0.0D0 /

C *** BETA3 AND ALP3 ARE THE BOND PARAMETERS USED IN THE
C     RESONANCE INTEGRAL AND THE CORE CORE REPULSION INTEGRAL RESPECTIVE
C     THAT IS ACCORDING TO THE FOLLOWING CONVENTION
C
C     HERE IS THE
C     BOND TYPE DESIGNATION
C
C
C         H   B   C   N   O   F  SI   P   S  CL
C       -----------------------------------------
C      H  1  11  16  22  29  37  92 106 121 137
C      B     15  20  26  33  41
C      C         21  27  34  42  97 111 126 142
C      N             28  35  43         127 143
C      O                 36  44         128 144
C      F                     45         129
C     SI                        105
C      P                            120     151
C      S                                136 152
C     CL                                    153

      DATA BETA3(1),ALP3(1)   /  0.244770D0 ,  1.489450D0 /
      DATA BETA3(11),ALP3(11)   /  0.185347D0 ,  2.090352D0 /
      DATA BETA3(15),ALP3(15)   /  0.151324D0 ,  2.280544D0 /
      DATA BETA3(16),ALP3(16)   /  0.315011D0 ,  1.475836D0 /
      DATA BETA3(20),ALP3(20)   /  0.250031D0 ,  2.138291D0 /
      DATA BETA3(21),ALP3(21)   /  0.419907D0 ,  1.371208D0 /
      DATA BETA3(22),ALP3(22)   /  0.360776D0 ,  0.589380D0 /
      DATA BETA3(26),ALP3(26)   /  0.310959D0 ,  1.909763D0 /
      DATA BETA3(27),ALP3(27)   /  0.410886D0 ,  1.635259D0 /
      DATA BETA3(28),ALP3(28) /  0.377342D0 ,  2.029618D0 /
      DATA BETA3(29),ALP3(29) /  0.417759D0 ,  0.478901D0 /
      DATA BETA3(33),ALP3(33) /  0.349745D0 ,  2.484827D0 /
      DATA BETA3(34),ALP3(34) /  0.464514D0 ,  1.820975D0 /
      DATA BETA3(35),ALP3(35) /  0.458110D0 ,  1.873859D0 /
      DATA BETA3(36),ALP3(36) /  0.659407D0 ,  1.537190D0 /
      DATA BETA3(37),ALP3(37) /  0.195242D0 ,  3.771362D0 /
      DATA BETA3(41),ALP3(41) /  0.219591D0 ,  2.862183D0 /
      DATA BETA3(42),ALP3(42) /  0.247494D0 ,  2.725913D0 /
      DATA BETA3(43),ALP3(43) /  0.205347D0 ,  2.861667D0 /
      DATA BETA3(44),ALP3(44) /  0.334044D0 ,  2.266949D0 /
      DATA BETA3(45),ALP3(45) /  0.197464D0 ,  3.864997D0 /
      DATA BETA3(92),ALP3(92) /  0.289647D0 ,  0.940789D0 /
      DATA BETA3(97),ALP3(97) /  0.411377D0 ,  1.101382D0 /
      DATA BETA3(105),ALP3(105) /  0.291703D0 ,  0.918432D0 /
      DATA BETA3(106),ALP3(106) /  0.320118D0 ,  0.923170D0 /
      DATA BETA3(111),ALP3(111) /  0.457816D0 ,  1.029693D0 /
      DATA BETA3(120),ALP3(120) /  0.311790D0 ,  1.186652D0 /
      DATA BETA3(121),ALP3(121) /  0.220654D0 ,  1.700698D0 /
      DATA BETA3(126),ALP3(126) /  0.284620D0 ,  1.761370D0 /
      DATA BETA3(127),ALP3(127) /  0.313170D0 ,  1.878176D0/
      DATA BETA3(128),ALP3(128) /  0.422890D0 ,  2.077240D0 /
      DATA BETA3(129),ALP3(129)  /  0.000000D0 ,  0.000000D0 /
      DATA BETA3(136),ALP3(136) /  0.202489D0 ,  1.751617D0 /
      DATA BETA3(137),ALP3(137) /  0.231653D0 ,  2.089404D0 /
      DATA BETA3(142),ALP3(142) /  0.315480D0 ,  1.676222D0 /
      DATA BETA3(143),ALP3(143) /  0.302298D0 ,  1.817064D0 /
      DATA BETA3(144),ALP3(144) /  0.000000D0 ,  0.000000D0 /
      DATA BETA3(151),ALP3(151) /  0.277322D0 ,  1.543720D0 /
      DATA BETA3(152),ALP3(152) /  0.221764D0 ,  1.950318D0 /
      DATA BETA3(153),ALP3(153) /  0.258969D0 ,  1.792125D0 /

C *** HERE COMES THE OPTIMIZED SLATER_S EXPONENTS FOR THE EVALUATION
C     OF THE OVERLAP INTEGRALS AND MOLECULAR DIPOLE MOMENTS.

      DATA ZS3(1),ZP3(1)      /  1.3D0       ,  0.0D0      /
      DATA ZS3(5),ZP3(5)      /  1.211156D0 ,  0.972826D0 /
      DATA ZS3(6),ZP3(6)      /  1.739391D0 ,  1.709645D0 /
      DATA ZS3(7),ZP3(7)      /  2.704546D0 ,  1.870839D0 /
      DATA ZS3(8),ZP3(8)      /  3.640575D0 ,  2.168448D0 /
      DATA ZS3(9),ZP3(9)      /  3.111270D0 ,  1.41986D0 /
      DATA ZS3(14),ZP3(14)    /  1.629173D0 ,  1.381721D0 /
      DATA ZS3(15),ZP3(15)    /  1.926108D0 ,  1.590665D0 /
      DATA ZS3(16),ZP3(16)    /  1.719480D0 ,  1.403205D0 /
      DATA ZS3(17),ZP3(17)    /  3.430887D0 ,  1.627017D0 /

*
*
*   END OF MINDO/3 SPECIFIC DATA
*
*
      END


*----------------------------------------------------------------------*
      integer function vtx_type(op)
*----------------------------------------------------------------------*
*     analyze blocks of operator and return type as defined in
*     def_operator.h
*----------------------------------------------------------------------*

      implicit none

      include 'opdim.h'
      include 'def_operator.h'
      include 'ifc_operators.h'

      type(operator), intent(in) ::
     &     op

      logical ::
     &     ex, dx, vl
      integer ::
     &     iblk, nblk
      integer, pointer ::
     &     hpvx_occ(:,:,:)

      hpvx_occ => op%ihpvca_occ
      nblk = op%n_occ_cls

      ex = .false.
      dx = .false.
      vl = .false.
      do iblk = 1, nblk
        ex = ex.or.iocc_nonzero(iocc_xdn(1,hpvx_occ(1:ngastp,1:2,iblk)))
        dx = dx.or.iocc_nonzero(iocc_xdn(2,hpvx_occ(1:ngastp,1:2,iblk)))
        vl = vl.or.iocc_nonzero(iocc_xdn(3,hpvx_occ(1:ngastp,1:2,iblk)))
      end do

      if (.not.ex.and..not.dx.and..not.vl) vtx_type = vtxtyp_scalar
      if (ex.and..not.dx.and..not.vl) vtx_type = vtxtyp_ph_ex
      if (dx.and..not.ex.and..not.vl) vtx_type = vtxtyp_ph_dx
      if (dx.and.ex.and..not.vl) vtx_type = vtxtyp_ph
      if (vl) vtx_type = vtxtyp_val

      return
      end


	SUBROUTINE RF_COLOR(io,t,x,y,inw,lun,bolflux,strmass,sf,evflux,snbr,pnbr,bh,sn,wd,rm,xm,bolms,gasmass,galmass,tmlr,tdpr)

!	Array declarations
	parameter (nc=100,lb=2*nc,jid=35,its=400)
	character genfile*96,envfile*96,rfcolorfile*96,h(0:200)*15	! ,h(0:200)*24
!	Negative indices allow for mandatory colors
	integer p,n1(-4:nc),n2(-4:nc),no(lb),ly(6),kerr(nc)
	real zp(-4:nc),col(-4:nc),phot(0:200),f(200),w(200),s(200)
	real umag,bmag,rmag,jmag,kmag,bsun,vsun,ksun,blr1,vlr1,klr1,blr,vlr,klr
	real x(inw),y(inw),fx(lb),balm(3),gwx(jid),ab(0:20)
	real m_pn,m_hm,m_bh,m_ns,m_wd
	save no,ly,zp,sl,mb,nv,mc,kb,nb,v0,p,w,s
	include 'stelib.dec'
	include 'filter.dec'
	common /kpercent/ ipcall,iplast,iphead,jc
!	Common to store fluxes used to compute indices
	integer iim(jid)
	real ffb(jid),ffr(jid),ffc(jid),ffl(jid)
	common /fluxes/ iim,ffb,ffr,ffc,ffl
	common /massrem/ m_pn,m_hm,m_bh,m_ns,m_wd
	real*8 mabo(its),mbel(its),mcut,rmup(its),rmlo(its)
	common /topimf/ mabo,mbel,rmup,rmlo,mcut,ic
	data icall/0/,ly/6*0/,last/0/
!	Define mandatory colors
	data n1/ 15,15,15,12,14, nc*0/
	data n2/125,57,84,13,15, nc*0/
	data kerr/nc*0/,jfits/0/
	common /f1001/ mab,ab

!	Return if t = 0 (log t undefined)
	if (t <= 0.) return

!	Check for zero flux sed
	if (bolflux <= 0.) then
		bolflux=trapz1(x,y,inw)
		if (bolflux <= 0.) return
	endif
	izero=0
	do i=1,inw
	if (y(i).gt.0) then
		izero=izero+1
	endif
	enddo
	if (izero.eq.0) then
!		write (6,*) 'Exiting rf_color at t =',t,' because of zero flux'
!		return
!		To allow using .?color files with a single number of lines
		do i=1,inw
		y(i) = 1.E-33
		enddo
	endif

!	Compute galaxy mass and mass in gas (except for add_bursts io = 5)
!	if (io.ne.10) then
!		galmass=gal_mass(io,t,sf)
!	endif

!	Compute Worthey indices directly from sed plus other indices
!	Store fluxes used to compute spectral indices in binary file
	do j=1,jid
	gwx(j)=gw_ix_sed(j,x,y,inw,0)
	enddo
!	Write results for gwx(j)
	tl=alog10(t)
!	write (lun+8,105)  tl,(gwx(j),j= 1,21)
!	write (lun+9,106)  tl,(gwx(j),j=22,25),(gwx(j),j=30,31),(gwx(j),j=26,29),(gwx(j),j=32,jid)
!	write (lun+10,110) (tl,j,iim(j),ffb(j),ffr(j),ffc(j),ffl(j),gwx(j),j=1,jid)
!105     format (f10.6,21f9.4)
!106     format (f10.6,1x,6f9.4,3f11.4,4f10.4,f10.4)
!110	format (f10.6,i4,i4,1p4e12.3,0pf12.4)
!106    format (f10.6,8f8.3,14f12.3)
!	write (lun+9,106) tl,(gwx(j),j=14,25),(gwx(j),j=30,31),(gwx(j),j=26,29),(gwx(j),j=32,jid)
!	write (lun+8,105) tl,(gwx(j),j= 1,13)

!	Check for stelib model
	if (stelib) then
		if (iphead.eq.0) then
!			Report what we are doing
			write (6,*)
!			write (6,'(x,a,$)') 'Computing SEDs and Indices'
			write (6,'(x,a/ )') 'Computing magnitudes, colours and indices'
			iphead=1
		endif
	endif
	if (stelib.or.inw.gt.6600) then
!		Compute indices in Lick system only for stelib or hr csp_galaxev models
		ism=0
		do j=1,jid
		gwx(j)=gw_ix_sed_lick_system(j,x,y,inw,0,ism)
		enddo
!		Write results for gwx(j)
!		write (lun+11,105) tl,(gwx(j),j= 1,21)
!		write (lun+12,106) tl,(gwx(j),j=22,25),(gwx(j),j=30,31),(gwx(j),j=26,29),(gwx(j),j=32,jid)
!		write (lun+11,105) tl,(gwx(j),j= 1,13)
!		write (lun+12,106) tl,(gwx(j),j=14,25),(gwx(j),j=30,31),(gwx(j),j=26,29),(gwx(j),j=32,34)
!		Do not compute colors for _hrs_ models
		if ((inw.eq.6700.or.inw.eq.15011).and.io.gt.0) return
	endif

!	Check if number of points has changed
	if (inw.ne.last) then
!		write (6,*) 'Resetting:',inw,last
!		ireset=1
		last=inw
	endif

	if (icall.eq.0) then
		icall=1

!		Format of file modified 07/01/2003:
!		To avoid recompiling this routine the arrays n1,n2 of
!		up to nc elements each are now read from a file.
!		Get file name from environment variable RF_COLORS_ARRAYS
		envfile='RF_COLORS_ARRAYS'
		call getenv(envfile,rfcolorfile)
		close (1)
		open (1,file=rfcolorfile,status='old',form='formatted',err=2)
!		write (6,*) 'List of filters in file: ',rfcolorfile(1:largo(rfcolorfile))
!		Read one line of header
		read (1,'(a)') genfile
!		write (6,*) genfile(1:largo(genfile))
		kb=0
!		Read filter pairs
		do i=1,nc
		read (1,'(2i4)',err=10) n1(i),n2(i)
		kb=kb+1
		fx(kb)=n1(i)
		kb=kb+1
		fx(kb)=n2(i)
		enddo
10		mc=i-1
		close (1)
!		Add mandatory filters
		do i=-4,0
		kb=kb+1
		fx(kb)=n1(i)
		kb=kb+1
		fx(kb)=n2(i)
		enddo
!		Sort filters in numerical order
		call sort(kb,fx)
!		Find independent filters in arrays n1 and n2, and store in no
		nb=1
		no(1)=fx(1)
		do i=2,kb
		if (fx(i).gt.fx(i-1)) then
			nb=nb+1
			no(nb)=nint(fx(i))
		endif
		enddo
!		Write filter ID
		call filterid(fid)
!		write (6,'(x,a)') 'Selected filters:'
!		do i=1,nb
!		write (6,'(i4,'': '',i4,3x,a)') i,no(i),fid(no(i))
!		enddo
!		write (6,'(i3,a)') mc,' colors selected:'
!		write (6,'(32i4)') (n1(i),i=1,mc)
!		write (6,'(32i4)') (n2(i),i=1,mc)

!		Log of solar luminosity
		sl=33.+alog10(3.826)

!		Read filter file and compute zero points
!		write (6,*)
!		write (6,*) 'Computing Zero Points:'
!		Compute V magnitude Vega zero point
		v0=vega_0p_n(15)
		do i=-4,mc
		zp(i)=zerop_n(n1(i),n2(i))

!		Fill arrays with filter numbers
		do j=1,nb
		if (n1(i).eq.no(j)) n1(i)=j
		if (n2(i).eq.no(j)) n2(i)=j
		if (no(j).eq.14) mb=j
		if (no(j).eq.15) nv=j
		enddo
		enddo

!		Find in array x the position of points used to define the
!		continuum at Lyman alpha
		do i=1,inw
		if (x(i).le.1120.) ly(1)=i
		if (x(i).le.1140.) ly(2)=i
		if (x(i).le.1160.) ly(3)=i
		if (x(i).le.1280.) ly(4)=i
		if (x(i).le.1300.) ly(5)=i
		if (x(i).ge.1320.) then
			ly(6)=i
			goto 1
		endif

		enddo
	endif
1	continue

!	Report what we are doing
	if (iphead.eq.0) then
		write (6,*)
!		write (6,'(x,a,$)') 'Computing SEDs and Colors. '
		write (6,'(x,a,$)') 'Computing magnitudes, colours and indices'
		iphead=1
	endif

!	Compute colors for SDSS
!	ireset=1
	call sdss_color(t,x,y,inw,lun,bolflux)

!	Compute flux through each of nb filters
	do i=1,nb
	kerr(i)=0	! This is useful just in case the first sed in a model has zero fluxes for a given filter
!			! otherwise the flux through this filter is not computed at later ages.
	if (kerr(i).eq.0) then
		fx(i)=filter_n(no(i),x,y,inw,0.,kerr(i))
	else
		fx(i)=0.
	endif
	enddo

!	Compute colors in Vega system
	do i=-4,mc
	if (fx(n1(i)).gt.0..and.fx(n2(i)).gt.0.) then
		col(i)=zp(i)-2.5*alog10(fx(n1(i))/fx(n2(i)))
!		write (6,*) i,n1(i),kerr(n1(i)),n2(i),kerr(n2(i))
	else
		col(i)=-99.99
!		write (6,*) i,n1(i),kerr(n1(i)),fx(n1(i)),n2(i),kerr(n2(i)),fx(n2(i))
	endif
	enddo

!	Compute bolometric magnitude
	bolmag=4.75-2.5*alog10(bolflux)
	bolpms=bolflux-bolms
	if (bolms.gt.0.) bolrat=bolpms/bolms

!	Compute V magnitude for a 1 Mo galaxy
!	It is -27.5 magnitudes brighter for a 1E11 Mo galaxy
	vmag=v0-2.5*alog10(fx(nv))

!	Compute U, B, R, K, and J2MASS magnitudes
	bmag=vmag+col( 0)
	umag=bmag+col(-1)
	rmag=vmag-col(-2)
	kmag=vmag-col(-3)
	jmag=vmag-col(-4)

!	Compute mass-to-visual-light ratio in solar units SUPERSEDED (Feb. 27, 2004).
!	Using a G2 V sed and the filters number 14 and 15
!	in the filter file, one derives:
!		fblue(sun) = 0.138Lo
!		fvis (sun) = 0.113Lo
!	This numbers apply only to the filters in this filter library.
!	Express blue and visual flux of model galaxy (also measured in
!	Lo) in units of the blue and visual flux of the sun:
!	fblu=fx(mb)/0.138
!	fvis=fx(nv)/0.113
!	fblu=filter(14,x,y,inw,0.)/0.138
!	fvis=filter(15,x,y,inw,0.)/0.113
!	Total mass in galaxy  = 1 Mo
!	Compute mass-to-visual-light ratio
!	blr=1./fblu
!	vlr=1./fvis
!	Compute stellar-mass-to--light ratios
!	blr=strmass/fblu
!	vlr=strmass/fvis

!	The solar absolute magnitudes for U,B,V,R,I,J,H,K were calibrated against the values
!	of Binney and Merrifield 1998, Galactic Astronomy, Table 2.1 (page 53), assuming
!	Bessell filters, and the offsets used to calibrate the entire set of filters.
!	Some values need checking - particularly those using UV filters (FOCA and Galex).
!	Taken from: http://mips.as.arizona.edu/~cnaw/sun.html

!		Filter	 B&M	 here	 difference
!		U	 5.61	 5.55	 0.06
!		B	 5.48	 5.45	 0.03
!		V	 4.83	 4.80	 0.03
!		R	 4.42	 4.46	 -0.04
!		I	 4.08	 4.11	 -0.03
!		J	 3.64	 3.67	 -0.02
!		H	 3.32	 3.33	 0.01
!		K	 3.28	 3.29	 0.01

!	Compute mass-to-visual-light ratio in solar units. Improved definition (Feb. 27, 2004).
!	Use solar absolute V and B magnitudes and (B-V)sun = 0.65
	vsun=4.80
	bsun=5.45
	ksun=3.29
!	M/L using the total mass in stars (M*), i.e. no remmnants
	blr1=strmass*10.**(0.4*(bmag-bsun))
	vlr1=strmass*10.**(0.4*(vmag-vsun))
	klr1=strmass*10.**(0.4*(kmag-ksun))
!	Modified Jan. 2011 to add mass of remmnants (rm = mBH + mNS + mWD)
	blr=(strmass+rm)*10.**(0.4*(bmag-bsun))
	vlr=(strmass+rm)*10.**(0.4*(vmag-vsun))
	klr=(strmass+rm)*10.**(0.4*(kmag-ksun))

!	Number of Lyman Continuum photons = Cly (log)
!	Flux in Lyman alpha from recombination theory
!	E(Lalpha) = 4.78E-13 * 33.1 * Nuv
!	log E = log(Nuv) -10.8 = cly -10.8
!	Number of Lyman continuum photons
	phly=clyman(x,y,inw)
	if (phly.gt.0.) then
		cly=sl+alog10(phly)
		fa=cly-10.8
	else
		cly=0.
		fa=0.
	endif

!	Number of Helium ionizing photons
	phe=chelium(x,y,inw,phe2)
	if (phe > 0.) then
		che=sl+alog10(phe)
	else
		che=0.
	endif
	if (phe2 > 0.) then
		che2=sl+alog10(phe2)
	else
		che2=0.
	endif

!	Stellar continuum at Lyman alpha
	if (x(1).ge.1320.) then
		scly=0.
	else
		scly=(y(ly(1))+y(ly(2))+y(ly(3))+y(ly(4))+y(ly(5))+y(ly(6)))/6.
	endif
	if (scly.gt.0.) then
		fc=sl+alog10(scly)
	else
		fc=0.
	endif

!	Ly alpha equivalent width assuming that the continuum is the stellar continuum
	if (fa.gt.0..and.fc.gt.0.) then
		ew=10.**(fa-fc)
		ew2=phly/scly/10.**(10.8)
	else
		ew=0.
		ew2=0.
	endif

!	Compute Mg2 index
	ymg2=ymag2(x,y,inw)

!	Compute 912 A break
	b9=b912(x,y,inw)

!	Compute 4000 A break
	b4=b4000(x,y,inw)

!	Compute narrow version of D4000
	b4_n=b4000vn(x,y,inw)

!	Compute SDSS version of D4000
	b4_s=b4000_sdss(x,y,inw)

!	Compute equivalent width of Balmer lines (Hgamma, Hdelta, Hbeta)
	ewbl=ew_balmer(x,y,inw,balm)

!	Compute bolometric magnitude
	bolmag=4.75-2.5*alog10(bolflux)

!	Compute specific flux, snbr, pnbr
	evf=evflux/bolflux
!	write (6,*) t,evflux,evf,xm
	snr=snbr/bolflux
	pnr=pnbr/bolflux

!	SFR/year
!	sf=sfr(t)

!	Compute quantities requested by C. Popescu
!	call popescu(tl,sf,x,y,inw)

!	Compute flux from 1500 to 2800A
!	it=0
!	do i=1,inw
!	if (x(i).ge.1500.0.and.x(i).le.2800.0) then
!		it=it+1
!		xx(it)=x(i)
!		yy(it)=y(i)
!	endif
!	enddo
!	fuv=trapz1(x,y,it)
!	write (9,*) tl, sf,fuv

!	Write results
!	write (lun+3 ,102) tl,b4,b4_n,b4_s,b9,cly,che,che2,bolmag,bolflux,snr,bh,sn,pnr,wd,rm
!	write (lun+4 ,103) tl,bolmag,bmag,vmag,kmag,strmass,rm,gasmass,galmass,sf,strmass+rm,blr,vlr,klr,blr1,vlr1,klr1
!	write (lun+5 ,104) tl,bolmag,evflux,evf,xm,bolrat
!	write (lun+1 ,101) tl,bolmag,umag,bmag,vmag,kmag,(col(i),i=1,9)
!	write (lun+2 ,101) tl,rmag,jmag,kmag,            (col(i),i=10,20)
!	write (lun+14,111) tl,     kmag,                 (col(i),i=21,31),tmlr,tdpr
!	write (lun+84,108) tl,vmag,kmag,                 (col(i),i=32,42),cly,blr,vlr,klr
!	write (lun+85,108) tl,vmag,kmag,                 (col(i),i=43,53),cly,blr,vlr,klr
!	write (lun+86,108) tl,vmag,kmag,                 (col(i),i=54,64),cly,blr,vlr,klr
!	write (lun+87,108) tl,vmag,                      (col(i),i=65,80)
!	write (lun+88,108) tl,vmag,kmag,                 (col(i),i=81,92),cly,blr,vlr,klr
!	write (lun+17,171) tl,mabo(ic),mbel(ic),mabo(ic)+mbel(ic),mcut,rmup(ic),rmlo(ic)    ! Esto escribe los datos requeridos por Alba (opcion kdist = 5)
!171	format (f10.6,1p6e12.3)
!101	format (f10.6,14f10.4,1pe13.4)
!102	format (f10.6,3f10.4,1pe12.3,1x,0p3f10.4,2x,f10.4,1p7e12.4)
!103	format (f10.6,4f10.4,1p6e13.4,1x,6e12.4)
!104	format (f10.6,f10.4,1p3e12.4,0pf10.4)
!108	format (f10.6,18f10.4)
!111	format (f10.6,12f10.4,1p2e13.4)

!	Organize photometric magnitudes in order to be listed in fits file
!	Write temporary file fort.1000 with photometric magnitudes to be inserted in fits file
	return					 ! comment this statement to get file fort.1000 written

!	Johnson UBVRIJKL filters
	p =   0 ; phot(p) = bolmag               ;                h(p) = '           Mbol'  !  Mbol
	p = p+1 ; phot(p) = umag                 ; f(p) =  12   ; h(p) = '      U_Johnson'  !  U
	p = p+1 ; phot(p) = bmag                 ; f(p) =  14   ; h(p) = '      B_Johnson'  !  B
	p = p+1 ; phot(p) = vmag                 ; f(p) =  15   ; h(p) = '      V_Johnson'  !  V
	p = p+1 ; phot(p) = vmag - col(76)       ; f(p) =  32   ; h(p) = '      R_Johnson'  !  R = V - (V-R)
	p = p+1 ; phot(p) = vmag - col(77)       ; f(p) =  33   ; h(p) = '      I_Johnson'  !  I = V - (V-I)
	p = p+1 ; phot(p) = vmag - col(78)       ; f(p) =  34   ; h(p) = '      J_Johnson'  !  J = V - (V-J)
	p = p+1 ; phot(p) = vmag - col(79)       ; f(p) =  35   ; h(p) = '      K_Johnson'  !  K = V - (V-K)
	p = p+1 ; phot(p) = vmag - col(80)       ; f(p) =  36   ; h(p) = '      L_Johnson'  !  L = V - (V-L)

!	Cousins RI filters
	p = p+1 ; phot(p) = rmag                 ; f(p) =  84   ; h(p) = '      R_Cousins'
	p = p+1 ; phot(p) = vmag - col(11)       ; f(p) =  85   ; h(p) = '      I_Cousins'  !  I = V - (V-I)

!	Palomar JHK filters
	p = p+1 ; phot(p) = vmag - col(12)       ; f(p) =  55   ; h(p) = '      J_Palomar'  !  J = V - (V-J)
	p = p+1 ; phot(p) = phot(p-1) - col(15)	 ; f(p) =  56   ; h(p) = '      H_Palomar'  !  H = J - (J-H)
	p = p+1 ; phot(p) = kmag                 ; f(p) =  57   ; h(p) = '      K_Palomar'

!	Cowie K' filter
	p = p+1 ; phot(p) = vmag - col(17) 	 ; f(p) =  88   ; h(p) = '   Kprime_Cowie'  !  K' = V - (V-K')

!	2Mass JHKs filters
	p = p+1 ; phot(p) = vmag - col(18) 	 ; f(p) = 125   ; h(p) = '        J_2Mass'  !  J2M = V - (V-J2M)    2M = 2Mass
	p = p+1 ; phot(p) = vmag - col(19) 	 ; f(p) = 126   ; h(p) = '        H_2Mass'  !  H2M = V - (V-H2M)    2M = 2Mass
	p = p+1 ; phot(p) = vmag - col(20) 	 ; f(p) = 127   ; h(p) = '       Ks_2Mass'  ! Ks2M = V - (V-Ks2M)   2M = 2Mass

!	IRAC + IRAS + MIPS IR filters
	p = p+1 ; phot(p) = kmag      - col(21)	 ; f(p) = 128   ; h(p) = '      I3p6_IRAC'  ! I3.5 = K    - (K-I3.5)      IRAC
	p = p+1 ; phot(p) = phot(p-1) - col(22)	 ; f(p) = 129   ; h(p) = '      I4p5_IRAC'  ! I4.5 = I3.5 - (I3.5-I4.5)   IRAC
	p = p+1 ; phot(p) = phot(p-1) - col(23)	 ; f(p) = 130   ; h(p) = '      I5p7_IRAC'  ! I5.7 = I4.5 - (I4.5-I5.7)   IRAC
	p = p+1 ; phot(p) = phot(p-1) - col(24)	 ; f(p) = 131   ; h(p) = '      I7p9_IRAC'  ! I7.9 = I5.7 - (I5.7-I7.9)   IRAC
	p = p+1 ; phot(p) = phot(p-1) - col(25)	 ; f(p) =  71   ; h(p) = '       I12_IRAS'  ! I12  = I7.9 - (I7.9 - I12)  IRAS
	p = p+1 ; phot(p) = phot(p-1) - col(26)	 ; f(p) =  72   ; h(p) = '       I25_IRAS'  ! I25  = I12  - (I12  - I25)  IRAS
	p = p+1 ; phot(p) = phot(p-1) - col(27)	 ; f(p) =  73   ; h(p) = '       I60_IRAS'  ! I60  = I25  - (I25  - I60)  IRAS
	p = p+1 ; phot(p) = phot(p-1) - col(28)	 ; f(p) =  74   ; h(p) = '      I100_IRAS'  ! I100 = I60  - (I60 - I100)  IRAS
	p = p+3 ; phot(p) = phot(p-3) - col(31)	 ; f(p) = 134   ; h(p) = '      M160_MIPS'  ! M160 = I100 - (I100 - M160) MIPS
	p = p-1 ; phot(p) = phot(p+1) + col(30)	 ; f(p) = 133   ; h(p) = '       M70_MIPS'  ! M70  = M160 + (M70  - M160) MIPS
	p = p-1 ; phot(p) = phot(p+1) + col(29)	 ; f(p) = 132   ; h(p) = '       M24_MIPS'  ! M24  = M70  + (M24  - M70 ) MIPS

!	HST ACS wide filters
	p = p+3 ; phot(p) = vmag - col(54)	 ; f(p) = 219   ; h(p) = '  ACS_WFC_F220w'  ! ACS WFC wide filter F220w = V - (V-F220w)
	p = p+1 ; phot(p) = vmag - col(55)	 ; f(p) = 220   ; h(p) = '  ACS_WFC_F250w'  ! ACS WFC wide filter F250w = V - (V-F250w)
	p = p+1 ; phot(p) = vmag - col(56)	 ; f(p) = 221   ; h(p) = '  ACS_WFC_F330w'  ! ACS WFC wide filter F330w = V - (V-F330w)
	p = p+1 ; phot(p) = vmag - col(57)	 ; f(p) = 222   ; h(p) = '  ACS_WFC_F410w'  ! ACS WFC wide filter F410w = V - (V-F410w)
	p = p+1 ; phot(p) = vmag - col(58)	 ; f(p) = 223   ; h(p) = '  ACS_WFC_F435w'  ! ACS WFC wide filter F435w = V - (V-F435w)
	p = p+1 ; phot(p) = vmag - col(59)	 ; f(p) = 224   ; h(p) = '  ACS_WFC_F475w'  ! ACS WFC wide filter F475w = V - (V-F475w)
	p = p+1 ; phot(p) = vmag - col(60)	 ; f(p) = 225   ; h(p) = '  ACS_WFC_F555w'  ! ACS WFC wide filter F555w = V - (V-F555w)
	p = p+1 ; phot(p) = vmag - col(61)	 ; f(p) = 226   ; h(p) = '  ACS_WFC_F606w'  ! ACS WFC wide filter F606w = V - (V-F606w)
	p = p+1 ; phot(p) = vmag - col(62)	 ; f(p) = 227   ; h(p) = '  ACS_WFC_F625w'  ! ACS WFC wide filter F625w = V - (V-F625w)
	p = p+1 ; phot(p) = vmag - col(63)	 ; f(p) = 228   ; h(p) = '  ACS_WFC_F775w'  ! ACS WFC wide filter F775w = V - (V-F775w)
	p = p+1 ; phot(p) = vmag - col(64)	 ; f(p) = 229   ; h(p) = '  ACS_WFC_F814w'  ! ACS WFC wide filter F814w = V - (V-F814w)

!	HST UVIS1 filters
	p = p+1 ; phot(p) = vmag - col(81)	 ; f(p) = 242   ; h(p) = '    UVIS1_f225w'  ! UVIS1 f225w = V - (V - f225w.UVIS1)
	p = p+1 ; phot(p) = vmag - col(82)	 ; f(p) = 243   ; h(p) = '    UVIS1_f275w'  ! UVIS1 f275w = V - (V - f275w.UVIS1)
	p = p+1 ; phot(p) = vmag - col(83)	 ; f(p) = 244   ; h(p) = '    UVIS1_f336w'  ! UVIS1 f336w = V - (V - f336w.UVIS1)
	p = p+1 ; phot(p) = vmag - col(84)	 ; f(p) = 245   ; h(p) = '    UVIS1_f438w'  ! UVIS1 f438w = V - (V - f438w.UVIS1)
	p = p+1 ; phot(p) = vmag - col(85)	 ; f(p) = 246   ; h(p) = '    UVIS1_f547m'  ! UVIS1 f547m = V - (V - f547m.UVIS1)
	p = p+1 ; phot(p) = vmag - col(86)	 ; f(p) = 247   ; h(p) = '    UVIS1_f555w'  ! UVIS1 f555w = V - (V - f555w.UVIS1)
	p = p+1 ; phot(p) = vmag - col(87)	 ; f(p) = 248   ; h(p) = '    UVIS1_f606w'  ! UVIS1 f606w = V - (V - f606w.UVIS1)
	p = p+1 ; phot(p) = vmag - col(88)	 ; f(p) = 249   ; h(p) = '    UVIS1_f625w'  ! UVIS1 f625w = V - (V - f625w.UVIS1)
	p = p+1 ; phot(p) = vmag - col(89)	 ; f(p) = 250   ; h(p) = '    UVIS1_f656n'  ! UVIS1 f656n = V - (V - f656n.UVIS1)
	p = p+1 ; phot(p) = vmag - col(90)	 ; f(p) = 251   ; h(p) = '    UVIS1_f657n'  ! UVIS1 f657n = V - (V - f657n.UVIS1)
	p = p+1 ; phot(p) = vmag - col(91)	 ; f(p) = 252   ; h(p) = '    UVIS1_f658n'  ! UVIS1 f658n = V - (V - f658n.UVIS1)
	p = p+1 ; phot(p) = vmag - col(92)	 ; f(p) = 253   ; h(p) = '    UVIS1_f814w'  ! UVIS1 f814w = V - (V - f814w.UVIS1)

!	AB mags
	p = p+1 ; phot(p) = ab (0)        	 ; f(p) = 120   ; h(p) = '      u_SDSS_AB'  ! SDSS u AB mag
	p = p+1 ; phot(p) = ab (1)        	 ; f(p) = 121   ; h(p) = '      g_SDSS_AB'  ! SDSS g AB mag
	p = p+1 ; phot(p) = ab (2)        	 ; f(p) = 122   ; h(p) = '      r_SDSS_AB'  ! SDSS r AB mag
	p = p+1 ; phot(p) = ab (3)        	 ; f(p) = 123   ; h(p) = '      i_SDSS_AB'  ! SDSS i AB mag
	p = p+1 ; phot(p) = ab (4)        	 ; f(p) = 124   ; h(p) = '      z_SDSS_AB'  ! SDSS z AB mag
	p = p+1 ; phot(p) = ab (5)        	 ; f(p) = 237   ; h(p) = '   u_CFHT_MC_AB'  ! CFHT MC u AB mag
	p = p+1 ; phot(p) = ab (6)        	 ; f(p) = 238   ; h(p) = '   g_CFHT_MC_AB'  ! CFHT MC g AB mag
	p = p+1 ; phot(p) = ab (7)        	 ; f(p) = 239   ; h(p) = '   r_CFHT_MC_AB'  ! CFHT MC r AB mag
	p = p+1 ; phot(p) = ab (8)        	 ; f(p) = 255   ; h(p) = '   i_CFHT_MC_AB'  ! CFHT MC i AB mag
	p = p+1 ; phot(p) = ab (9)        	 ; f(p) = 115   ; h(p) = '   y_CFHT_MC_AB'  ! CFHT MC y AB mag
	p = p+1 ; phot(p) = ab (10)        	 ; f(p) = 241   ; h(p) = '   z_CFHT_MC_AB'  ! CFHT MC z AB mag
	p = p+1 ; phot(p) = ab (11)        	 ; f(p) = 256   ; h(p) = '  Ks_CFHT_MC_AB'  ! CFHT MC Ks AB mag
	p = p+1 ; phot(p) = ab (12)        	 ; f(p) = 139   ; h(p) = '   FUV_GALEX_AB'  ! GALEX 1500 AB mag
	p = p+1 ; phot(p) = ab (13)        	 ; f(p) = 140   ; h(p) = '   NUV_GALEX_AB'  ! GALEX 2300 AB mag

!	Write temporary file fort.1000 with photometric magnitudes to be inserted in fits file
	if (jfits == 0) then
		jfits = 1
!		Compute effective wavelength for each of the p filtes
		do i=1,p
		s(i) = i
		area = areafilt(int(f(i)),w(i))
		enddo
!		Sort in increasing order of effective wavelength
		call sort2(p,w,s)
!		  do i=1,p
!		  j = s(i)
!		  write (1006,*) i,w(i),'   ',h(j)
!		  write (1006,*) i+2,'   ',h(j)
!		  enddo
!		  stop
!		  write (1000, '(a)') '# logage_yr   Mbol    U       B       V       R       I       J       K       L       Rc      Ic      Jp      Hp      Kp      Kpr     J2M     H2M    Ks2M    I3p6    I4p5    I5p7    I7p9    I12     I25     I60     I100     M24     M70    M160  A_F220w A_F250w A_F330w A_F410w A_F435w A_F475w A_F555w A_F606w A_F625w A_F775w A_F814w U_f225w U_f275w U_f336w U_f438w U_f547m U_f555w U_f606w U_f625w U_f656n U_f657n U_f658n U_f814w'
!		  write (1001, '(a)') '    u       g       r       i       z      u_MC    g_MC    r_MC    i_MC    y_MC    z_MC    Ks_MC   FUV     NUV'
!		write (1000, '(201(a,2x))') '# logage_yr',(trim(h(i)),i=0,p)
!		write (1000, '(201(a,3x))') '# logage_yr',trim(h(0)),(trim(h(int(s(i)))),i=1,p)
!		write (1000, '(201(a,2x))') '# logage_yr',     h(0),(h(int(s(i))),i=1,p)
		write (1000, '(201(a   ))') '# logage_yr',     h(0),(h(int(s(i))),i=1,p)
!		write (6,*) p+1,' magnitudes stored in temporary file fort.1000'
	endif
!	write (1000,109) tl,(phot(i),i=0,p)
	write (1000,109) tl,phot(0),(phot(int(s(i))),i=1,p)
109	format (f11.6,90f15.4)
	do i=1,p
	write (1001,112) tl,phot(int(s(i))),w(int(s(i)))
	enddo
112	format (f10.6,f12.4,f12.1)
	return
2	write (6,*) 'Error opening file: ',rfcolorfile(1:largo(rfcolorfile))
	stop
	end


!
! Example_NakajimaKing.f90
!
! Modified simple example from CRTM library test cases.
! Includes: 155 Atmospheric layers
!           2 Absorbers
!           1 cloud
!
! Record of revisions:
! ====================
!
! Author:       Date:       Modification:
! =======       =====       =============
! P. van Delst  2013-06-20  Original CRTM lib example.
! P. Stegmann   2016-06-06  Modified the original example in order to fit it to
!                           Guanglin's problem of calculating MODIS band 31
!                           radiances. Included custom atmosphere profile and a
!                           4-layer cloud.
! P. Stegmann   2019-11-06  Modified as an example producing a Nakajima-King
!                           diagram for MODIS Ch. 2 and 7.
!

PROGRAM Example_NakajimaKing

  ! ============================================================================
  ! **** ENVIRONMENT SETUP FOR RTM USAGE ****
  !
  ! Module usage
  USE CRTM_Module
  ! Disable all implicit typing
  IMPLICIT NONE
  ! ============================================================================

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: PROGRAM_NAME   = 'Example_NakajimaKing'
  CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = &
    '$Id: Example_NakajimaKing.f90 29405 2019-11-06 $'
  CHARACTER(*), PARAMETER :: RESULTS_PATH = './results/'

  ! ============================================================================
  ! 0. **** SOME SET UP PARAMETERS FOR THIS EXAMPLE ****
  !
  ! Profile dimensions...
  INTEGER, PARAMETER :: N_PROFILES  = 100
  INTEGER, PARAMETER :: N_LAYERS    = 155
  INTEGER, PARAMETER :: N_ABSORBERS = 2
  INTEGER, PARAMETER :: N_CLOUDS    = 1
  INTEGER, PARAMETER :: N_AEROSOLS  = 0
  ! ...but only ONE Sensor at a time
  INTEGER, PARAMETER :: N_SENSORS = 1
  ! ...and that sensor is Aqua MODIS
  CHARACTER(*), PARAMETER :: SENSOR_ID = 'v.modis_aqua'
  ! ============================================================================
  REAL(fp) :: ZENITH_ANGLE = 60.0_fp
  REAL(fp) :: SCAN_ANGLE   = 26.37293341421_fp

  ! ---------
  ! Variables
  ! ---------
  CHARACTER(256) :: Message
  CHARACTER(256) :: Version
  INTEGER :: Error_Status
  INTEGER :: Allocate_Status
  INTEGER :: n_Channels
  INTEGER :: l, m, ii
  INTEGER :: k1, k2
  ! Declarations for RTSolution comparison
  INTEGER :: n_l, n_m
  CHARACTER(256) :: rts_File
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: rts(:,:)
  TYPE(CRTM_Options_type)                 :: Options(N_PROFILES)

  ! ============================================================================
  ! 1. **** DEFINE THE CRTM INTERFACE STRUCTURES ****
  !
  TYPE(CRTM_ChannelInfo_type)             :: ChannelInfo(N_SENSORS)
  TYPE(CRTM_Geometry_type)                :: Geometry(N_PROFILES)
  TYPE(CRTM_Atmosphere_type)              :: Atm(N_PROFILES)
  TYPE(CRTM_Surface_type)                 :: Sfc(N_PROFILES)
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution(:,:)
  TYPE(CRTM_Options_type)                 :: Opt(N_PROFILES)
  ! ============================================================================

  ! Program header
  ! --------------
  CALL CRTM_Version( Version )
  CALL Program_Message( PROGRAM_NAME, &
    'Program to provide a (relatively) simple example of how '//&
    'to call the CRTM Forward function.', &
    'CRTM Version: '//TRIM(Version) )

  ! Get sensor id from user
  ! -----------------------
  !WRITE( *,'(/5x,"Enter sensor id [hirs4_n18, amsua_metop-a, or mhs_n18]: ")',ADVANCE='NO' )
  !READ( *,'(a)' ) Sensor_Id
  !Sensor_Id = ADJUSTL("amsua_metop-a")
  !WRITE( *,'(//5x,"Running CRTM for ",a," sensor...")' ) TRIM(Sensor_Id)
  ! Output some info about what's going on...
  ! -----------------------------------------
  WRITE( *,'(//5x,"Running CRTM for ",a," sensor...")' ) SENSOR_ID

  ! ============================================================================
  ! 2. **** INITIALIZE THE CRTM ****
  !
  ! 2a. This initializes the CRTM for the sensors
  !     predefined in the example SENSOR_ID parameter.
  !     NOTE: The coefficient data file path is hard-
  !           wired for this example.
  ! --------------------------------------------------
  WRITE( *,'(/5x,"Initializing the CRTM...")' )
  Error_Status = CRTM_Init( (/Sensor_Id/), &  ! Input... must be an array, hence the (/../)
                            ChannelInfo  , &  ! Output
                            IRwaterCoeff_File = 'WuSmith.IRwater.EmisCoeff.bin', &
                            MWwaterCoeff_File = 'FASTEM5.MWwater.EmisCoeff.bin', &
                            File_Path='coefficients/')
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error initializing CRTM'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP
  END IF

  ! 2b. Select the MODIS channel subset
  !     that is to be processed.
  !     NOTE: Channel list is sorted
  !     into ascending order for
  !     processing.
  ! ----------------------------------
  Error_Status = CRTM_ChannelInfo_Subset( ChannelInfo(1), &
                                          Channel_Subset = (/ 2, 7 /) )

  ! 2b. Determine the total number of channels
  !     for which the CRTM was initialized
  ! ------------------------------------------
  n_Channels = SUM(CRTM_ChannelInfo_n_Channels(ChannelInfo))
  ! ============================================================================

  ! 2d. Output some info about the subsetting
  ! -----------------------------------------
  WRITE( *,'(/5x,"Processing the following ",i0," channels of ",a,":")' ) n_Channels, SENSOR_ID
  WRITE( *,'(1x,10i5)' ) CRTM_ChannelInfo_Channels(ChannelInfo(1))
  ! ============================================================================

  ! ============================================================================
  ! 3. **** ALLOCATE STRUCTURE ARRAYS ****
  !
  ! 3a. Allocate the ARRAYS
  ! -----------------------
  ! Note that only those structure arrays with a channel
  ! dimension are allocated here because we've parameterized
  ! the number of profiles in the N_PROFILES parameter.
  !
  ! Users can make the number of profiles dynamic also, but
  ! then the INPUT arrays (Atm, Sfc) will also have to be allocated.
  ALLOCATE( RTSolution( n_Channels, N_PROFILES ), STAT=Allocate_Status )
  IF ( Allocate_Status /= 0 ) THEN
    Message = 'Error allocating structure arrays'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP
  END IF

  ! 3b. Allocate the STRUCTURES
  ! ---------------------------
  ! The input FORWARD structure
  CALL CRTM_Atmosphere_Create( Atm, N_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS )
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atm)) ) THEN
    Message = 'Error allocating CRTM Atmosphere structures'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP
  END IF
  ! ============================================================================

  ! ============================================================================
  ! 4. **** ASSIGN INPUT DATA ****
  !
  ! Fill the Atm structure array.
  ! NOTE: This is an example program for illustrative purposes only.
  !       Typically, one would not assign the data as shown below,
  !       but rather read it from file

  ! 4a. Atmosphere and Surface input
  ! --------------------------------
  CALL Load_AtmSfc_Data()

  ! 4c. Option input
  ! ----------------
  ! Ancillary Input: set parameters for SSMIS Zeeman channels (ch19 - 22)
  !   Field_Strength - Earth magnetic field, in Gauss unit ( 0.2 - 0.7)
  !   COS_ThetaB - Consine of the angle between the magnetic field and
  !                propagation direction of the electromagnetic wave ( -1 - 1)
  !   Doppler_Shift - frequent shift in KHz (-80 - 80)
  DO m = 1, N_PROFILES
    CALL Zeeman_Input_SetValue( Options(m)%Zeeman, &
                                Field_Strength=0.35_fp, &
                                COS_ThetaB    =0.5_fp, &
                                Doppler_Shift =60.0_fp )
  END DO

  ! 4b. GeometryInfo input
  ! ----------------------
  ! All profiles are given the same value
  !  The Sensor_Scan_Angle is optional.
  ! This needs to be included in a loop in order to cover the entire hemisphere.

  ! Test GeometryInfo angles. The test scan angle is based
  ! on the default Re (earth radius) and h (satellite height)
  ! Satellite ZENITH_ANGLE will go from 90 to -90 degrees
  ZENITH_ANGLE = 45.0_fp
  SCAN_ANGLE   = 1.0_fp ! Creates the field of view
  ! Update satellite view geometry.
  CALL CRTM_Geometry_SetValue( Geometry, &
                               Sensor_Zenith_Angle = ZENITH_ANGLE, &
                               Sensor_Scan_Angle   = SCAN_ANGLE )

  ! Update satellite view geometry.
  CALL CRTM_Geometry_SetValue( Geometry, &
                               Sensor_Zenith_Angle = ZENITH_ANGLE, &
                               Sensor_Scan_Angle   = SCAN_ANGLE, &
                               Source_Zenith_Angle = 60.0_fp, &
                               Source_Azimuth_Angle = 0.0_fp, &
                               Flux_Zenith_Angle = ACOS(3.0_fp/5.0_fp)    )
  ! ============================================================================

  ! ============================================================================
  ! 5. **** SET RT FORWARD MODEL OPTIONS ****
  !
  Opt(1)%RT_Algorithm_Id = RT_ADA
  Opt(1)%Include_Scattering = .TRUE.
  Opt(1)%Use_n_Streams = .TRUE.
  Opt(1)%n_Streams = 16

  ! ============================================================================
  ! 5. **** CALL THE CRTM FORWARD MODEL ****
  !
  Error_Status = CRTM_Forward( Atm        , &
                               Sfc        , &
                               Geometry   , &
                               ChannelInfo, &
                               RTSolution, &
                               Options = Opt )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error in CRTM Forward Model'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP
  END IF
  ! ============================================================================

  ! ============================================================================
  ! 6. **** OUTPUT THE RESULTS TO SCREEN ****
  !
  ! User should read the user guide or the source code of the routine
  ! CRTM_RTSolution_Inspect in the file CRTM_RTSolution_Define.f90 to
  ! select the needed variables for outputs.  These variables are contained
  ! in the structure RTSolution.
  DO m = 1, N_PROFILES
    WRITE( *,'(//7x,"Profile ",i0," output for ",a )') m, TRIM(Sensor_Id)
    DO l = 1, n_Channels
      WRITE( *, '(/5x,"Channel ",i0," results")') RTSolution(l,m)%Sensor_Channel
      CALL CRTM_RTSolution_Inspect(RTSolution(l,m))
    END DO
  END DO
  ! ============================================================================

  ! Write solution radiances to file output.txt
  OPEN(111, FILE='output.txt', ACCESS='APPEND')

  DO m = 1, N_PROFILES
    !WRITE(111,*) 'Hi'
    !WRITE(111,*) (RTSolution(l,m)%Radiance,l=1,n_Channels)
    WRITE(111,'(16es14.6,16es14.6,16es14.6)') Atm(m)%Cloud(1)%Effective_Radius(10), &
                                     Atm(m)%Cloud(1)%Water_Content(10), &
                                     (RTSolution(l,m)%Radiance,l=1,n_Channels)
    !WRITE(*,*) RTSolution(l,1)%Radiance
  END DO

  close(111)

! END DO zenith_angle_loop

  ! ============================================================================
  ! 7. **** DESTROY THE CRTM ****
  !
  WRITE( *, '( /5x, "Destroying the CRTM..." )' )
  Error_Status = CRTM_Destroy( ChannelInfo )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error destroying CRTM'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP
  END IF
  ! ============================================================================

  ! ============================================================================
  ! 9. **** CLEAN UP ****
  !
  ! 9a. Deallocate the structures.
  !     These are the explicitly allocated structures.
  !     Note that in some cases other structures, such as the Sfc
  !     and RTSolution structures, will also be allocated and thus
  !     should also be deallocated here.
  ! -------------------------------------------------------------
  CALL CRTM_Atmosphere_Destroy(Atm)

  ! 9b. Deallocate the arrays
  ! -------------------------
  DEALLOCATE(RTSolution, rts, STAT=Allocate_Status)
  ! ============================================================================

  ! Signal the completion of the program. It is not a necessary step for running CRTM.
  CALL SignalFile_Create()

  WRITE(*,*) 'The program has been successfully completed.'

CONTAINS

  ! -------------------------------------------------
  ! Internal subprogam to load some test profile data
  ! -------------------------------------------------
  SUBROUTINE Load_AtmSfc_Data()

    INTEGER, PARAMETER :: SEA_WATER_TYPE  = 1
    INTEGER :: mm, nn

  Effective_Rad_loop: DO mm = 0, 9
    Tau_loop: DO nn = 1, 10
      !WRITE(*,*) mm, nn, 10*mm + nn

    ! 4a.1 Profile #1
    ! ---------------
    ! Surface data
    Sfc(10*mm + nn)%Water_Coverage    = 1.0_fp
    Sfc(10*mm + nn)%Water_Type        = SEA_WATER_TYPE
    Sfc(10*mm + nn)%Water_Temperature = 287.0_fp
    Sfc(10*mm + nn)%Wind_Speed        = 10.0_fp  ! (m/s)

    ! Atmospheric profile data
    !Atm(1)%Climatology = US_STANDARD_ATMOSPHERE
    Atm(10*mm + nn)%Absorber_Id    = (/ H2O_ID                 , O3_ID /)
    Atm(10*mm + nn)%Absorber_Units = (/ MASS_MIXING_RATIO_UNITS, VOLUME_MIXING_RATIO_UNITS /)

    ! Cloud data
    k1 = 10 ! Begin cloud layer
    k2 = 11 ! End cloud layer
    Atm(10*mm + nn)%Cloud(1)%Type = SNOW_CLOUD
    Atm(10*mm + nn)%Cloud(1)%Effective_Radius(k1:k2) = &
        (/1.5_fp + mm*1.0_fp/)  ! microns
    Atm(10*mm + nn)%Cloud(1)%Water_Content(k1:k2) = &
    	(/0.06_fp + (nn-1)*0.01_fp/) ! kg/m^2

    ! Level pressure (mb)
    Atm(10*mm + nn)%Level_Pressure = (/&
        7.1000e-05, 8.2000e-05, 9.4000e-05, 1.0900e-04, 1.2600e-04, 1.4500e-04,&
        1.7000e-04, 1.9900e-04, 2.3300e-04, 2.7300e-04, 3.2000e-04, 3.8000e-04,&
        4.5200e-04, 5.3800e-04, 6.3900e-04, 7.6000e-04, 9.0700e-04, 1.0820e-03,&
        1.2920e-03, 1.5420e-03, 1.8400e-03, 2.1960e-03, 2.6220e-03, 3.1300e-03,&
        3.7360e-03, 4.4600e-03, 5.2930e-03, 6.2820e-03, 7.4550e-03, 8.8470e-03,&
        1.0500e-02, 1.2388e-02, 1.4615e-02, 1.7243e-02, 2.0343e-02, 2.4000e-02,&
        2.8035e-02, 3.2749e-02, 3.8255e-02, 4.4687e-02, 5.2200e-02, 6.0481e-02,&
        7.0077e-02, 8.1194e-02, 9.4075e-02, 1.0900e-01, 1.2532e-01, 1.4409e-01,&
        1.6567e-01, 1.9048e-01, 2.1900e-01, 2.5005e-01, 2.8551e-01, 3.2599e-01,&
        3.7222e-01, 4.2500e-01, 4.8205e-01, 5.4675e-01, 6.2014e-01, 7.0339e-01,&
        7.9780e-01, 9.0387e-01, 1.0240e+00, 1.1605e+00, 1.3154e+00, 1.4910e+00,&
        1.6968e+00, 1.9310e+00, 2.2014e+00, 2.5140e+00, 2.8710e+00, 3.3269e+00,&
        3.8552e+00, 4.4291e+00, 5.0447e+00, 5.7460e+00, 6.5625e+00, 7.4951e+00,&
        8.6801e+00, 1.0193e+01, 1.1970e+01, 1.3912e+01, 1.6168e+01, 1.8807e+01,&
        2.0922e+01, 2.3453e+01, 2.6183e+01, 2.9121e+01, 3.2274e+01, 3.5651e+01,&
        3.9257e+01, 4.3100e+01, 4.7188e+01, 5.1528e+01, 5.6126e+01, 6.0989e+01,&
        6.6125e+01, 7.1540e+01, 7.7240e+01, 8.3231e+01, 8.9520e+01, 9.6114e+01,&
        1.0302e+02, 1.1024e+02, 1.1778e+02, 1.2565e+02, 1.3385e+02, 1.4238e+02,&
        1.5127e+02, 1.6050e+02, 1.7008e+02, 1.8002e+02, 1.9032e+02, 2.0099e+02,&
        2.1203e+02, 2.2344e+02, 2.3523e+02, 2.4741e+02, 2.5997e+02, 2.7292e+02,&
        2.8626e+02, 3.0000e+02, 3.1414e+02, 3.2868e+02, 3.4362e+02, 3.5897e+02,&
        3.7472e+02, 3.9089e+02, 4.0747e+02, 4.2447e+02, 4.4188e+02, 4.5971e+02,&
        4.7796e+02, 4.9663e+02, 5.1572e+02, 5.3523e+02, 5.5517e+02, 5.7552e+02,&
        5.9631e+02, 6.1751e+02, 6.3914e+02, 6.6119e+02, 6.8367e+02, 7.0657e+02,&
        7.2989e+02, 7.5363e+02, 7.7779e+02, 8.0237e+02, 8.2737e+02, 8.5279e+02,&
        8.7862e+02, 9.0487e+02, 9.3152e+02, 9.5859e+02, 9.8607e+02, 1.0139e+03 /)

    ! Layer pressure (mb)
    Atm(10*mm + nn)%Pressure = (/&
        7.6368e-05, 8.7863e-05, 1.0132e-04, 1.1729e-04, 1.3528e-04, 1.5717e-04,&
        1.8412e-04, 2.1555e-04, 2.5247e-04, 2.9588e-04, 3.4914e-04, 4.1496e-04,&
        4.9375e-04, 5.8705e-04, 6.9775e-04, 8.3134e-04, 9.9193e-04, 1.1839e-03,&
        1.4133e-03, 1.6866e-03, 2.0128e-03, 2.4027e-03, 2.8685e-03, 3.4241e-03,&
        4.0873e-03, 4.8646e-03, 5.7734e-03, 6.8518e-03, 8.1312e-03, 9.6499e-03,&
        1.1418e-02, 1.3471e-02, 1.5893e-02, 1.8750e-02, 2.2121e-02, 2.5965e-02,&
        3.0331e-02, 3.5431e-02, 4.1388e-02, 4.8346e-02, 5.6239e-02, 6.5161e-02,&
        7.5499e-02, 8.7476e-02, 1.0135e-01, 1.1697e-01, 1.3449e-01, 1.5463e-01,&
        1.7779e-01, 2.0441e-01, 2.3418e-01, 2.6739e-01, 3.0530e-01, 3.4859e-01,&
        3.9803e-01, 4.5293e-01, 5.1372e-01, 5.8267e-01, 6.6089e-01, 7.4960e-01,&
        8.4973e-01, 9.6269e-01, 1.0908e+00, 1.2363e+00, 1.4014e+00, 1.5917e+00,&
        1.8114e+00, 2.0632e+00, 2.3542e+00, 2.6886e+00, 3.0934e+00, 3.5846e+00,&
        4.1355e+00, 4.7302e+00, 5.3877e+00, 6.1452e+00, 7.0185e+00, 8.0731e+00,&
        9.4163e+00, 1.1058e+01, 1.2917e+01, 1.5012e+01, 1.7454e+01, 1.9846e+01,&
        2.2163e+01, 2.4793e+01, 2.7626e+01, 3.0670e+01, 3.3934e+01, 3.7425e+01,&
        4.1149e+01, 4.5113e+01, 4.9326e+01, 5.3794e+01, 5.8524e+01, 6.3522e+01,&
        6.8797e+01, 7.4354e+01, 8.0198e+01, 8.6337e+01, 9.2778e+01, 9.9527e+01,&
        1.0659e+02, 1.1397e+02, 1.2167e+02, 1.2971e+02, 1.3807e+02, 1.4678e+02,&
        1.5584e+02, 1.6524e+02, 1.7500e+02, 1.8512e+02, 1.9561e+02, 2.0646e+02,&
        2.1769e+02, 2.2928e+02, 2.4127e+02, 2.5364e+02, 2.6639e+02, 2.7954e+02,&
        2.9308e+02, 3.0702e+02, 3.2136e+02, 3.3609e+02, 3.5124e+02, 3.6679e+02,&
        3.8275e+02, 3.9912e+02, 4.1591e+02, 4.3312e+02, 4.5074e+02, 4.6878e+02,&
        4.8724e+02, 5.0611e+02, 5.2541e+02, 5.4514e+02, 5.6528e+02, 5.8585e+02,&
        6.0685e+02, 6.2826e+02, 6.5010e+02, 6.7237e+02, 6.9506e+02, 7.1817e+02,&
        7.4170e+02, 7.6565e+02, 7.9002e+02, 8.1481e+02, 8.4002e+02, 8.6564e+02,&
        8.9168e+02, 9.1813e+02, 9.4499e+02, 9.7226e+02, 9.9992e+02 /)

    ! Layer temperature (K)
    Atm(10*mm + nn)%Temperature = (/&
        236.855, 230.725, 224.505, 218.105, 211.870, 207.425, 204.685, 201.955,&
        199.220, 196.475, 194.435, 193.095, 191.750, 190.410, 189.070, 188.250,&
        187.950, 187.650, 187.350, 187.050, 187.100, 187.500, 187.900, 188.300,&
        188.700, 189.870, 191.810, 193.750, 195.690, 197.630, 199.580, 201.540,&
        203.500, 205.460, 207.420, 209.520, 211.760, 214.000, 216.240, 218.480,&
        220.970, 223.710, 226.450, 229.190, 231.930, 234.670, 237.410, 240.150,&
        242.890, 245.630, 248.380, 251.140, 253.900, 256.660, 259.420, 261.790,&
        263.770, 265.750, 267.730, 269.710, 270.680, 270.640, 269.970, 268.040,&
        265.480, 262.820, 260.060, 257.300, 254.540, 251.780, 248.900, 245.900,&
        243.010, 240.340, 237.780, 235.200, 232.600, 230.300, 228.600, 227.200,&
        226.000, 225.000, 224.010, 223.185, 222.490, 221.780, 221.080, 220.395,&
        219.740, 219.110, 218.500, 217.905, 217.360, 216.905, 216.700, 216.700,&
        216.700, 216.700, 216.700, 216.700, 216.700, 216.700, 216.700, 216.700,&
        216.700, 216.700, 216.700, 216.700, 216.700, 216.700, 216.700, 216.700,&
        216.710, 216.740, 216.775, 217.545, 219.360, 221.460, 223.525, 225.565,&
        227.580, 229.580, 231.585, 233.575, 235.535, 237.490, 239.435, 241.350,&
        243.250, 245.145, 247.015, 248.860, 250.705, 252.535, 254.335, 256.125,&
        257.910, 259.675, 261.410, 263.145, 264.875, 266.575, 268.255, 269.935,&
        271.605, 273.250, 274.880, 276.500, 278.115, 279.710, 281.285, 282.855,&
        284.420, 285.970, 287.495 /)

    ! Layer H2O profile (mixing ratio, g/kg)
    Atm(10*mm + nn)%Absorber(:,1) = (/&
     1.780e-04,1.852e-04,1.927e-04,2.003e-04,2.078e-04,2.152e-04,2.227e-04,2.301e-04,&
     2.376e-04,2.451e-04,2.574e-04,2.748e-04,2.924e-04,3.098e-04,3.271e-04,3.551e-04,&
     3.936e-04,4.323e-04,4.709e-04,5.094e-04,5.585e-04,6.182e-04,6.779e-04,7.376e-04,&
     7.974e-04,8.721e-04,9.614e-04,1.051e-03,1.141e-03,1.230e-03,1.323e-03,1.420e-03,&
     1.516e-03,1.613e-03,1.709e-03,1.799e-03,1.883e-03,1.967e-03,2.051e-03,2.135e-03,&
     2.221e-03,2.307e-03,2.394e-03,2.481e-03,2.569e-03,2.647e-03,2.715e-03,2.784e-03,&
     2.852e-03,2.921e-03,2.976e-03,3.020e-03,3.063e-03,3.107e-03,3.150e-03,3.180e-03,&
     3.196e-03,3.211e-03,3.227e-03,3.242e-03,3.253e-03,3.259e-03,3.262e-03,3.259e-03,&
     3.253e-03,3.241e-03,3.222e-03,3.201e-03,3.173e-03,3.142e-03,3.117e-03,3.097e-03,&
     3.081e-03,3.067e-03,3.054e-03,3.038e-03,3.020e-03,2.999e-03,2.976e-03,2.952e-03,&
     2.921e-03,2.883e-03,2.846e-03,2.814e-03,2.787e-03,2.756e-03,2.712e-03,2.663e-03,&
     2.619e-03,2.571e-03,2.526e-03,2.489e-03,2.460e-03,2.435e-03,2.414e-03,2.399e-03,&
     2.389e-03,2.383e-03,2.385e-03,2.394e-03,2.413e-03,2.441e-03,2.587e-03,2.856e-03,&
     3.119e-03,3.361e-03,3.629e-03,4.370e-03,5.538e-03,6.846e-03,8.500e-03,1.033e-02,&
     1.274e-02,1.605e-02,1.963e-02,2.436e-02,3.075e-02,3.755e-02,4.759e-02,6.300e-02,&
     8.028e-02,1.024e-01,1.361e-01,1.758e-01,2.149e-01,2.535e-01,2.917e-01,3.292e-01,&
     3.772e-01,4.384e-01,5.017e-01,5.675e-01,6.435e-01,7.261e-01,8.074e-01,9.064e-01,&
     1.030e+00,1.158e+00,1.286e+00,1.435e+00,1.604e+00,1.771e+00,1.944e+00,2.150e+00,&
     2.382e+00,2.610e+00,2.836e+00,3.060e+00,3.282e+00,3.501e+00,3.722e+00,3.961e+00,&
     4.212e+00,4.460e+00,4.705e+00 /)

    ! Dummy layer O3 profile (volume mixing ratio, ppmv)
    Atm(10*mm + nn)%Absorber(:,2) = 0.01_fp
   END DO Tau_loop
  END DO Effective_Rad_loop

  END SUBROUTINE Load_AtmSfc_Data

  INCLUDE 'SignalFile_Create.inc'

END PROGRAM Example_NakajimaKing


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:34:36 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE SURFLUX__genmod
          INTERFACE
            SUBROUTINE SURFLUX(ISTEP,OTEMP,OSALN,ATEMP,ASHUM,SICH,SICA, &
     &TICE,ALBICE,STRESSXU_OCN,STRESSYU_OCN,STRESSXV_OCN,STRESSYV_OCN,  &
     &ALBEDO,FXLHO,FXSHO,FXSWO,FXLWO,EVAP_OCN,PPTN_OCN,RUNOFF_OCN,      &
     &RUNOFF_LAND,FXLHA,FXSHA,FXSWA,FXLWA,EVAP_ATM,PPTN_ATM,DTHSIC,     &
     &DTAREASIC,ATMOS_LOWESTLH_ATM,GO_SOLFOR,GO_FXSW,DUM_N_ATM,         &
     &DUM_SFCATM,EB_CA,GN_DAYSPERYEAR,EB_FX0A,EB_FX0O,EB_FXSEN,EB_FXLW, &
     &EB_EVAP,EB_PPTN,EB_RELH,EB_UV,EB_USURF,SOLCONST,CO2_OUT,CH4_OUT,  &
     &N2O_OUT,SURF_OROG_ATM,LANDICE_SLICEMASK_LIC,ALBS_ATM,             &
     &LAND_ALBS_SNOW_LND,LAND_ALBS_NOSNOW_LND,LAND_SNOW_LND,            &
     &LAND_BCAP_LND,LAND_Z0_LND,LAND_TEMP_LND,LAND_MOISTURE_LND,        &
     &FLAG_ENTS,LOWESTLU2_ATM,LOWESTLV3_ATM)
              COMMON/EMBM_INVARS/ IMAX,JMAX,KMAX,LMAX,NTOT,INTOT,K1,KU, &
     &MK,NYEAR
                INTEGER(KIND=4) :: IMAX
                INTEGER(KIND=4) :: JMAX
                INTEGER(KIND=4) :: KMAX
                INTEGER(KIND=4) :: LMAX
                INTEGER(KIND=4) :: NTOT
                INTEGER(KIND=4) :: INTOT
                INTEGER(KIND=4) :: K1(0:37,0:37)
                INTEGER(KIND=4) :: KU(2,36,36)
                INTEGER(KIND=4) :: MK(37,36)
                INTEGER(KIND=4) :: NYEAR
              INTEGER(KIND=4), INTENT(IN) :: DUM_N_ATM
              INTEGER(KIND=4) :: ISTEP
              REAL(KIND=8) :: OTEMP(IMAX,JMAX)
              REAL(KIND=8) :: OSALN(IMAX,JMAX)
              REAL(KIND=8) :: ATEMP(IMAX,JMAX)
              REAL(KIND=8) :: ASHUM(IMAX,JMAX)
              REAL(KIND=8) :: SICH(IMAX,JMAX)
              REAL(KIND=8) :: SICA(IMAX,JMAX)
              REAL(KIND=8) :: TICE(IMAX,JMAX)
              REAL(KIND=8) :: ALBICE(IMAX,JMAX)
              REAL(KIND=8) :: STRESSXU_OCN(IMAX,JMAX)
              REAL(KIND=8) :: STRESSYU_OCN(IMAX,JMAX)
              REAL(KIND=8) :: STRESSXV_OCN(IMAX,JMAX)
              REAL(KIND=8) :: STRESSYV_OCN(IMAX,JMAX)
              REAL(KIND=8) :: ALBEDO(IMAX,JMAX)
              REAL(KIND=8) :: FXLHO(IMAX,JMAX)
              REAL(KIND=8) :: FXSHO(IMAX,JMAX)
              REAL(KIND=8) :: FXSWO(IMAX,JMAX)
              REAL(KIND=8) :: FXLWO(IMAX,JMAX)
              REAL(KIND=8) :: EVAP_OCN(IMAX,JMAX)
              REAL(KIND=8) :: PPTN_OCN(IMAX,JMAX)
              REAL(KIND=8) :: RUNOFF_OCN(IMAX,JMAX)
              REAL(KIND=8) :: RUNOFF_LAND(IMAX,JMAX)
              REAL(KIND=8) :: FXLHA(IMAX,JMAX)
              REAL(KIND=8) :: FXSHA(IMAX,JMAX)
              REAL(KIND=8) :: FXSWA(IMAX,JMAX)
              REAL(KIND=8) :: FXLWA(IMAX,JMAX)
              REAL(KIND=8) :: EVAP_ATM(IMAX,JMAX)
              REAL(KIND=8) :: PPTN_ATM(IMAX,JMAX)
              REAL(KIND=8) :: DTHSIC(IMAX,JMAX)
              REAL(KIND=8) :: DTAREASIC(IMAX,JMAX)
              REAL(KIND=8), INTENT(OUT) :: ATMOS_LOWESTLH_ATM(IMAX,JMAX)
              REAL(KIND=8) :: GO_SOLFOR(JMAX)
              REAL(KIND=8) :: GO_FXSW(IMAX,JMAX)
              REAL(KIND=8), INTENT(IN) :: DUM_SFCATM(DUM_N_ATM,IMAX,JMAX&
     &)
              REAL(KIND=8), INTENT(IN) :: EB_CA(IMAX,JMAX)
              REAL(KIND=8) :: GN_DAYSPERYEAR
              REAL(KIND=8) :: EB_FX0A(IMAX,JMAX)
              REAL(KIND=8) :: EB_FX0O(IMAX,JMAX)
              REAL(KIND=8) :: EB_FXSEN(IMAX,JMAX)
              REAL(KIND=8) :: EB_FXLW(IMAX,JMAX)
              REAL(KIND=8) :: EB_EVAP(IMAX,JMAX)
              REAL(KIND=8) :: EB_PPTN(IMAX,JMAX)
              REAL(KIND=8) :: EB_RELH(IMAX,JMAX)
              REAL(KIND=8) :: EB_UV(2,IMAX,JMAX)
              REAL(KIND=8) :: EB_USURF(IMAX,JMAX)
              REAL(KIND=8) :: SOLCONST
              REAL(KIND=8) :: CO2_OUT(IMAX,JMAX)
              REAL(KIND=8) :: CH4_OUT(IMAX,JMAX)
              REAL(KIND=8) :: N2O_OUT(IMAX,JMAX)
              REAL(KIND=8), INTENT(INOUT) :: SURF_OROG_ATM(IMAX,JMAX)
              REAL(KIND=8), INTENT(OUT) :: LANDICE_SLICEMASK_LIC(36,36)
              REAL(KIND=8), INTENT(INOUT) :: ALBS_ATM(36,36)
              REAL(KIND=8), INTENT(IN) :: LAND_ALBS_SNOW_LND(36,36)
              REAL(KIND=8), INTENT(IN) :: LAND_ALBS_NOSNOW_LND(36,36)
              REAL(KIND=8), INTENT(INOUT) :: LAND_SNOW_LND(36,36)
              REAL(KIND=8), INTENT(INOUT) :: LAND_BCAP_LND(36,36)
              REAL(KIND=8), INTENT(INOUT) :: LAND_Z0_LND(36,36)
              REAL(KIND=8), INTENT(INOUT) :: LAND_TEMP_LND(36,36)
              REAL(KIND=8), INTENT(INOUT) :: LAND_MOISTURE_LND(36,36)
              LOGICAL(KIND=4) :: FLAG_ENTS
              REAL(KIND=8), INTENT(INOUT) :: LOWESTLU2_ATM(36,36)
              REAL(KIND=8), INTENT(INOUT) :: LOWESTLV3_ATM(36,36)
            END SUBROUTINE SURFLUX
          END INTERFACE
        END MODULE SURFLUX__genmod


! Code automatically generated by 'PreSARAH'
! Expressions for amplitudes are obtained by FeynArts/FormCalc
! Created at 10:37 on 11.11.2016

Module DecayFFS

Use Control
Use LoopFunctions
Use AddLoopFunctions
Use Settings

Contains

Subroutine TreeAmp_FtoFS(Mex1,Mex2,Mex3,coupT1L, coupT1R,Amplitude)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(out) :: Amplitude(2)
Complex(dp), Intent(in) :: coupT1L, coupT1R

Amplitude = 0._dp

! Now the full amplitude for the different Lorentz Parts
! Coefficient of Mat[<v1|6|v2>]
Amplitude(1)= -1*(0.,1._dp)*coupT1R

! Coefficient of Mat[<v1|7|v2>]
Amplitude(2)= -1*(0.,1._dp)*coupT1L

End Subroutine TreeAmp_FtoFS

! --------------------------------------
! Topology Nr.1
! --------------------------------------

Subroutine Amp_VERTEX_FtoFS_Topology1_SFF(Mex1,Mex2,Mex3,ML1, ML2, ML3,coup1L, coup1R, coup2L, coup2R, coup3L, coup3R,Amplitude)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(out) :: Amplitude(2)
Real(dp), Intent(in) :: ML1, ML2, ML3
Complex(dp), Intent(in) :: coup1L, coup1R, coup2L, coup2R, coup3L, coup3R
Complex(dp) :: int1,int2,int3,int4,int5,int6,int7,int8,int9,int10

Amplitude = 0._dp

! Necessary Loop Integrals
int1=SA_B0(Mex3**2,ML2**2,ML3**2)
int2=SA_Cget("C0  ",Mex3**2,Mex1**2,Mex2**2,ML3**2,ML2**2,ML1**2)
int3=SA_Cget("C1  ",Mex3**2,Mex1**2,Mex2**2,ML3**2,ML2**2,ML1**2)
int4=SA_Cget("C2  ",Mex3**2,Mex1**2,Mex2**2,ML3**2,ML2**2,ML1**2)

! Now the full amplitude for the different Lorentz Parts
! Coefficient of Mat[<v1|6|v2>]
Amplitude(1)= &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3L*int1) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3L*int3*Mex1**2) &
& +(-1*(0.,1._dp)*coup1L*coup2L*coup3R*int4*Mex1*Mex2) &
& +(-1*(0.,1._dp)*coup1R*coup2R*coup3L*int2*Mex2**2) &
& +(-1*(0.,1._dp)*coup1R*coup2R*coup3L*int3*Mex2**2) &
& +(-1*(0.,1._dp)*coup1R*coup2R*coup3L*int4*Mex2**2) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3L*int2*ML1**2) &
& +(1*(0.,1._dp)*coup1L*coup2R*coup3L*int3*Mex1*ML2) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3R*int3*Mex2*ML2) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3R*int4*Mex2*ML2) &
& +(1*(0.,1._dp)*coup1L*coup2R*coup3R*int2*Mex1*ML3) &
& +(1*(0.,1._dp)*coup1L*coup2R*coup3R*int3*Mex1*ML3) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3L*int2*Mex2*ML3) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3L*int3*Mex2*ML3) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3L*int4*Mex2*ML3) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3R*int2*ML2*ML3)

! Coefficient of Mat[<v1|7|v2>]
Amplitude(2)= &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3R*int1) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3R*int3*Mex1**2) &
& +(-1*(0.,1._dp)*coup1R*coup2R*coup3L*int4*Mex1*Mex2) &
& +(-1*(0.,1._dp)*coup1L*coup2L*coup3R*int2*Mex2**2) &
& +(-1*(0.,1._dp)*coup1L*coup2L*coup3R*int3*Mex2**2) &
& +(-1*(0.,1._dp)*coup1L*coup2L*coup3R*int4*Mex2**2) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3R*int2*ML1**2) &
& +(1*(0.,1._dp)*coup1R*coup2L*coup3R*int3*Mex1*ML2) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3L*int3*Mex2*ML2) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3L*int4*Mex2*ML2) &
& +(1*(0.,1._dp)*coup1R*coup2L*coup3L*int2*Mex1*ML3) &
& +(1*(0.,1._dp)*coup1R*coup2L*coup3L*int3*Mex1*ML3) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3R*int2*Mex2*ML3) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3R*int3*Mex2*ML3) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3R*int4*Mex2*ML3) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3L*int2*ML2*ML3)

If ((Abs(Amplitude(1))).ne.(Abs(Amplitude(1)))) Then
Amplitude=0._dp
End if

!Field Order
! FieldOrder[1,{S, F, F},1]={AntiField[Internal[2]][i2], External[1][gt1], Internal[1][i1]};
! FieldOrder[1,{S, F, F},2]={External[2][gt2], Internal[3][i3], AntiField[Internal[1]][i1]};
! FieldOrder[1,{S, F, F},3]={AntiField[Internal[3]][i3], Internal[2][i2], External[3][gt3]};
! ExtraSign[1,{S, F, F},1]=1;
! ExtraSign[1,{S, F, F},2]=1;
! ExtraSign[1,{S, F, F},3]=1;
End Subroutine Amp_VERTEX_FtoFS_Topology1_SFF

Subroutine Amp_VERTEX_FtoFS_Topology1_FSS(Mex1,Mex2,Mex3,ML1, ML2, ML3,coup1L, coup1R, coup2L, coup2R, coup3,Amplitude)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(out) :: Amplitude(2)
Real(dp), Intent(in) :: ML1, ML2, ML3
Complex(dp), Intent(in) :: coup1L, coup1R, coup2L, coup2R, coup3
Complex(dp) :: int1,int2,int3,int4,int5,int6,int7,int8,int9,int10

Amplitude = 0._dp

! Necessary Loop Integrals
int1=SA_Cget("C0  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int2=SA_Cget("C1  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int3=SA_Cget("C2  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)

! Now the full amplitude for the different Lorentz Parts
! Coefficient of Mat[<v1|6|v2>]
Amplitude(1)= &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3*int3*Mex1) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3*int2*Mex2) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3*int1*ML1)

! Coefficient of Mat[<v1|7|v2>]
Amplitude(2)= &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3*int3*Mex1) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3*int2*Mex2) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3*int1*ML1)

If ((Abs(Amplitude(1))).ne.(Abs(Amplitude(1)))) Then
Amplitude=0._dp
End if

!Field Order
! FieldOrder[1,{F, S, S},1]={Internal[1][i1], External[1][gt1], AntiField[Internal[2]][i2]};
! FieldOrder[1,{F, S, S},2]={External[2][gt2], AntiField[Internal[1]][i1], Internal[3][i3]};
! FieldOrder[1,{F, S, S},3]={External[3][gt3], Internal[2][i2], AntiField[Internal[3]][i3]};
! ExtraSign[1,{F, S, S},1]=1;
! ExtraSign[1,{F, S, S},2]=1;
! ExtraSign[1,{F, S, S},3]=1;
End Subroutine Amp_VERTEX_FtoFS_Topology1_FSS

Subroutine Amp_VERTEX_FtoFS_Topology1_VFF(Mex1,Mex2,Mex3,ML1, ML2, ML3,coup1L, coup1R, coup2L, coup2R, coup3L, coup3R,Amplitude)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(out) :: Amplitude(2)
Real(dp), Intent(in) :: ML1, ML2, ML3
Complex(dp), Intent(in) :: coup1L, coup1R, coup2L, coup2R, coup3L, coup3R
Complex(dp) :: int1,int2,int3,int4,int5,int6,int7,int8,int9,int10

Amplitude = 0._dp

! Necessary Loop Integrals
int1=SA_B0(Mex3**2,ML2**2,ML3**2)
int2=SA_Cget("C0  ",Mex3**2,Mex1**2,Mex2**2,ML3**2,ML2**2,ML1**2)
int3=SA_Cget("C1  ",Mex3**2,Mex1**2,Mex2**2,ML3**2,ML2**2,ML1**2)
int4=SA_Cget("C2  ",Mex3**2,Mex1**2,Mex2**2,ML3**2,ML2**2,ML1**2)

! Now the full amplitude for the different Lorentz Parts
! Coefficient of Mat[<v1|6|v2>]
Amplitude(1)= &
& +(2*(0.,1._dp)*coup1R*coup2L*coup3R*rMS) &
& +(-4*(0.,1._dp)*coup1R*coup2L*coup3R*int1) &
& +(-4*(0.,1._dp)*coup1R*coup2L*coup3R*int3*Mex1**2) &
& +(2*(0.,1._dp)*coup1R*coup2L*coup3R*int4*Mex1**2) &
& +(4*(0.,1._dp)*coup1R*coup2L*coup3R*int2*Mex2**2) &
& +(4*(0.,1._dp)*coup1R*coup2L*coup3R*int3*Mex2**2) &
& +(6*(0.,1._dp)*coup1R*coup2L*coup3R*int4*Mex2**2) &
& +(-2*(0.,1._dp)*coup1R*coup2L*coup3R*int4*Mex3**2) &
& +(-4*(0.,1._dp)*coup1R*coup2L*coup3R*int2*ML1**2) &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3R*int3*Mex1*ML2) &
& +(-2*(0.,1._dp)*coup1R*coup2R*coup3L*int3*Mex2*ML2) &
& +(-2*(0.,1._dp)*coup1R*coup2R*coup3L*int4*Mex2*ML2) &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3L*int2*Mex1*ML3) &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3L*int3*Mex1*ML3) &
& +(-2*(0.,1._dp)*coup1R*coup2R*coup3R*int2*Mex2*ML3) &
& +(-2*(0.,1._dp)*coup1R*coup2R*coup3R*int3*Mex2*ML3) &
& +(-2*(0.,1._dp)*coup1R*coup2R*coup3R*int4*Mex2*ML3) &
& +(-4*(0.,1._dp)*coup1R*coup2L*coup3L*int2*ML2*ML3)

! Coefficient of Mat[<v1|7|v2>]
Amplitude(2)= &
& +(2*(0.,1._dp)*coup1L*coup2R*coup3L*rMS) &
& +(-4*(0.,1._dp)*coup1L*coup2R*coup3L*int1) &
& +(-4*(0.,1._dp)*coup1L*coup2R*coup3L*int3*Mex1**2) &
& +(2*(0.,1._dp)*coup1L*coup2R*coup3L*int4*Mex1**2) &
& +(4*(0.,1._dp)*coup1L*coup2R*coup3L*int2*Mex2**2) &
& +(4*(0.,1._dp)*coup1L*coup2R*coup3L*int3*Mex2**2) &
& +(6*(0.,1._dp)*coup1L*coup2R*coup3L*int4*Mex2**2) &
& +(-2*(0.,1._dp)*coup1L*coup2R*coup3L*int4*Mex3**2) &
& +(-4*(0.,1._dp)*coup1L*coup2R*coup3L*int2*ML1**2) &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3L*int3*Mex1*ML2) &
& +(-2*(0.,1._dp)*coup1L*coup2L*coup3R*int3*Mex2*ML2) &
& +(-2*(0.,1._dp)*coup1L*coup2L*coup3R*int4*Mex2*ML2) &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3R*int2*Mex1*ML3) &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3R*int3*Mex1*ML3) &
& +(-2*(0.,1._dp)*coup1L*coup2L*coup3L*int2*Mex2*ML3) &
& +(-2*(0.,1._dp)*coup1L*coup2L*coup3L*int3*Mex2*ML3) &
& +(-2*(0.,1._dp)*coup1L*coup2L*coup3L*int4*Mex2*ML3) &
& +(-4*(0.,1._dp)*coup1L*coup2R*coup3R*int2*ML2*ML3)

If ((Abs(Amplitude(1))).ne.(Abs(Amplitude(1)))) Then
Amplitude=0._dp
End if

!Field Order
! FieldOrder[1,{V, F, F},1]={AntiField[Internal[2]][i2], External[1][gt1], Internal[1][i1]};
! FieldOrder[1,{V, F, F},2]={External[2][gt2], Internal[3][i3], AntiField[Internal[1]][i1]};
! FieldOrder[1,{V, F, F},3]={AntiField[Internal[3]][i3], Internal[2][i2], External[3][gt3]};
! ExtraSign[1,{V, F, F},1]=1;
! ExtraSign[1,{V, F, F},2]=1;
! ExtraSign[1,{V, F, F},3]=1;
End Subroutine Amp_VERTEX_FtoFS_Topology1_VFF

Subroutine Amp_VERTEX_FtoFS_Topology1_FSV(Mex1,Mex2,Mex3,ML1, ML2, ML3,coup1L, coup1R, coup2L, coup2R, coup3,Amplitude)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(out) :: Amplitude(2)
Real(dp), Intent(in) :: ML1, ML2, ML3
Complex(dp), Intent(in) :: coup1L, coup1R, coup2L, coup2R, coup3
Complex(dp) :: int1,int2,int3,int4,int5,int6,int7,int8,int9,int10

Amplitude = 0._dp

! Necessary Loop Integrals
int1=SA_B0(Mex3**2,ML2**2,ML3**2)
int2=SA_Cget("C0  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int3=SA_Cget("C1  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int4=SA_Cget("C2  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)

! Now the full amplitude for the different Lorentz Parts
! Coefficient of Mat[<v1|6|v2>]
Amplitude(1)= &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3*int1) &
& +(-2*(0.,1._dp)*coup1R*coup2L*coup3*int3*Mex1**2) &
& +(-2*(0.,1._dp)*coup1R*coup2L*coup3*int4*Mex1**2) &
& +(2*(0.,1._dp)*coup1L*coup2R*coup3*int3*Mex1*Mex2) &
& +(1*(0.,1._dp)*coup1L*coup2R*coup3*int4*Mex1*Mex2) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3*int3*Mex2**2) &
& +(2*(0.,1._dp)*coup1R*coup2L*coup3*int3*Mex3**2) &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3*int2*Mex1*ML1) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3*int4*Mex1*ML1) &
& +(-1*(0.,1._dp)*coup1R*coup2R*coup3*int2*Mex2*ML1) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3*int3*Mex2*ML1) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3*int2*ML1**2)

! Coefficient of Mat[<v1|7|v2>]
Amplitude(2)= &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3*int1) &
& +(-2*(0.,1._dp)*coup1L*coup2R*coup3*int3*Mex1**2) &
& +(-2*(0.,1._dp)*coup1L*coup2R*coup3*int4*Mex1**2) &
& +(2*(0.,1._dp)*coup1R*coup2L*coup3*int3*Mex1*Mex2) &
& +(1*(0.,1._dp)*coup1R*coup2L*coup3*int4*Mex1*Mex2) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3*int3*Mex2**2) &
& +(2*(0.,1._dp)*coup1L*coup2R*coup3*int3*Mex3**2) &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3*int2*Mex1*ML1) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3*int4*Mex1*ML1) &
& +(-1*(0.,1._dp)*coup1L*coup2L*coup3*int2*Mex2*ML1) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3*int3*Mex2*ML1) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3*int2*ML1**2)

If ((Abs(Amplitude(1))).ne.(Abs(Amplitude(1)))) Then
Amplitude=0._dp
End if

!Field Order
! FieldOrder[1,{F, S, V},1]={Internal[1][i1], External[1][gt1], AntiField[Internal[2]][i2]};
! FieldOrder[1,{F, S, V},2]={External[2][gt2], AntiField[Internal[1]][i1], Internal[3][i3]};
! FieldOrder[1,{F, S, V},3]={External[3][gt3], Internal[2][i2], AntiField[Internal[3]][i3]};
! ExtraSign[1,{F, S, V},1]=1;
! ExtraSign[1,{F, S, V},2]=1;
! ExtraSign[1,{F, S, V},3]=1;
End Subroutine Amp_VERTEX_FtoFS_Topology1_FSV

Subroutine Amp_VERTEX_FtoFS_Topology1_FVS(Mex1,Mex2,Mex3,ML1, ML2, ML3,coup1L, coup1R, coup2L, coup2R, coup3,Amplitude)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(out) :: Amplitude(2)
Real(dp), Intent(in) :: ML1, ML2, ML3
Complex(dp), Intent(in) :: coup1L, coup1R, coup2L, coup2R, coup3
Complex(dp) :: int1,int2,int3,int4,int5,int6,int7,int8,int9,int10

Amplitude = 0._dp

! Necessary Loop Integrals
int1=SA_B0(Mex3**2,ML3**2,ML2**2)
int2=SA_Cget("C0  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int3=SA_Cget("C1  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int4=SA_Cget("C2  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)

! Now the full amplitude for the different Lorentz Parts
! Coefficient of Mat[<v1|6|v2>]
Amplitude(1)= &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3*int1) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3*int4*Mex1**2) &
& +(-1*(0.,1._dp)*coup1L*coup2L*coup3*int3*Mex1*Mex2) &
& +(-2*(0.,1._dp)*coup1L*coup2L*coup3*int4*Mex1*Mex2) &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3*int3*Mex2**2) &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3*int4*Mex2**2) &
& +(-2*(0.,1._dp)*coup1R*coup2R*coup3*int4*Mex3**2) &
& +(1*(0.,1._dp)*coup1L*coup2R*coup3*int2*Mex1*ML1) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3*int4*Mex1*ML1) &
& +(-2*(0.,1._dp)*coup1R*coup2L*coup3*int2*Mex2*ML1) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3*int3*Mex2*ML1) &
& +(1*(0.,1._dp)*coup1R*coup2R*coup3*int2*ML1**2)

! Coefficient of Mat[<v1|7|v2>]
Amplitude(2)= &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3*int1) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3*int4*Mex1**2) &
& +(-1*(0.,1._dp)*coup1R*coup2R*coup3*int3*Mex1*Mex2) &
& +(-2*(0.,1._dp)*coup1R*coup2R*coup3*int4*Mex1*Mex2) &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3*int3*Mex2**2) &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3*int4*Mex2**2) &
& +(-2*(0.,1._dp)*coup1L*coup2L*coup3*int4*Mex3**2) &
& +(1*(0.,1._dp)*coup1R*coup2L*coup3*int2*Mex1*ML1) &
& +(-1*(0.,1._dp)*coup1R*coup2L*coup3*int4*Mex1*ML1) &
& +(-2*(0.,1._dp)*coup1L*coup2R*coup3*int2*Mex2*ML1) &
& +(-1*(0.,1._dp)*coup1L*coup2R*coup3*int3*Mex2*ML1) &
& +(1*(0.,1._dp)*coup1L*coup2L*coup3*int2*ML1**2)

If ((Abs(Amplitude(1))).ne.(Abs(Amplitude(1)))) Then
Amplitude=0._dp
End if

!Field Order
! FieldOrder[1,{F, V, S},1]={Internal[1][i1], External[1][gt1], AntiField[Internal[2]][i2]};
! FieldOrder[1,{F, V, S},2]={External[2][gt2], AntiField[Internal[1]][i1], Internal[3][i3]};
! FieldOrder[1,{F, V, S},3]={External[3][gt3], AntiField[Internal[3]][i3], Internal[2][i2]};
! ExtraSign[1,{F, V, S},1]=1;
! ExtraSign[1,{F, V, S},2]=1;
! ExtraSign[1,{F, V, S},3]=1;
End Subroutine Amp_VERTEX_FtoFS_Topology1_FVS

Subroutine Amp_VERTEX_FtoFS_Topology1_FVV(Mex1,Mex2,Mex3,ML1, ML2, ML3,coup1L, coup1R, coup2L, coup2R, coup3,Amplitude)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(out) :: Amplitude(2)
Real(dp), Intent(in) :: ML1, ML2, ML3
Complex(dp), Intent(in) :: coup1L, coup1R, coup2L, coup2R, coup3
Complex(dp) :: int1,int2,int3,int4,int5,int6,int7,int8,int9,int10

Amplitude = 0._dp

! Necessary Loop Integrals
int1=SA_Cget("C0  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int2=SA_Cget("C1  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)
int3=SA_Cget("C2  ",Mex2**2,Mex3**2,Mex1**2,ML1**2,ML3**2,ML2**2)

! Now the full amplitude for the different Lorentz Parts
! Coefficient of Mat[<v1|6|v2>]
Amplitude(1)= &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3*int3*Mex1) &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3*int2*Mex2) &
& +(4*(0.,1._dp)*coup1R*coup2L*coup3*int1*ML1)

! Coefficient of Mat[<v1|7|v2>]
Amplitude(2)= &
& +(2*(0.,1._dp)*coup1R*coup2R*coup3*int3*Mex1) &
& +(2*(0.,1._dp)*coup1L*coup2L*coup3*int2*Mex2) &
& +(4*(0.,1._dp)*coup1L*coup2R*coup3*int1*ML1)

If ((Abs(Amplitude(1))).ne.(Abs(Amplitude(1)))) Then
Amplitude=0._dp
End if

!Field Order
! FieldOrder[1,{F, V, V},1]={Internal[1][i1], External[1][gt1], AntiField[Internal[2]][i2]};
! FieldOrder[1,{F, V, V},2]={External[2][gt2], AntiField[Internal[1]][i1], Internal[3][i3]};
! FieldOrder[1,{F, V, V},3]={External[3][gt3], Internal[2][i2], AntiField[Internal[3]][i3]};
! ExtraSign[1,{F, V, V},1]=1;
! ExtraSign[1,{F, V, V},2]=1;
! ExtraSign[1,{F, V, V},3]=1;
End Subroutine Amp_VERTEX_FtoFS_Topology1_FVV

Subroutine SquareAmp_FtoFS(Mex1,Mex2,Mex3,Amplitude,AmplitudeC,AmpSquared)
Implicit None
Real(dp), Intent(in) :: Mex1,Mex2,Mex3
Complex(dp), Intent(in) :: Amplitude(2), AmplitudeC(2)
Real(dp), Intent(out) :: AmpSquared
Real(dp) :: LorentzFactor

AmpSquared = 0._dp

! Mat[<v1|6|v2>] x Mat[<v1|6|v2>]
LorentzFactor = (Mex1**2 + Mex2**2 - Mex3**2)/4._dp
AmpSquared = AmpSquared + LorentzFactor*Amplitude(1)*Conjg(AmplitudeC(1))

! Mat[<v1|6|v2>] x Mat[<v1|7|v2>]
LorentzFactor = (Mex1*Mex2)/2._dp
AmpSquared = AmpSquared + LorentzFactor*Amplitude(1)*Conjg(AmplitudeC(2))

! Mat[<v1|7|v2>] x Mat[<v1|6|v2>]
LorentzFactor = (Mex1*Mex2)/2._dp
AmpSquared = AmpSquared + LorentzFactor*Amplitude(2)*Conjg(AmplitudeC(1))

! Mat[<v1|7|v2>] x Mat[<v1|7|v2>]
LorentzFactor = (Mex1**2 + Mex2**2 - Mex3**2)/4._dp
AmpSquared = AmpSquared + LorentzFactor*Amplitude(2)*Conjg(AmplitudeC(2))
End Subroutine SquareAmp_FtoFS
End Module DecayFFS


      module rrlw_kg15

      use parkind ,only : im => kind_im, rb => kind_rb

      implicit none
      save

!-----------------------------------------------------------------
! rrtmg_lw ORIGINAL abs. coefficients for interval 15
! band 15:  2380-2600 cm-1 (low - n2o,co2; high - nothing)
!
! Initial version:  JJMorcrette, ECMWF, jul1998
! Revised: MJIacono, AER, jun2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
!  name     type     purpose
!  ----   : ----   : ---------------------------------------------
!fracrefao: real
! kao     : real
! kao_mn2 : real
! selfrefo: real
! forrefo : real
!-----------------------------------------------------------------

      integer(kind=im), parameter :: no15 = 16

      real(kind=rb) :: fracrefao(no15,9)
      real(kind=rb) :: kao(9,5,13,no15)
      real(kind=rb) :: kao_mn2(9,19,no15)
      real(kind=rb) :: selfrefo(10,no15)
      real(kind=rb) :: forrefo(4,no15)

!-----------------------------------------------------------------
! rrtmg_lw COMBINED abs. coefficients for interval 15
! band 15:  2380-2600 cm-1 (low - n2o,co2; high - nothing)
!
! Initial version:  JJMorcrette, ECMWF, jul1998
! Revised: MJIacono, AER, jun2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
!  name     type     purpose
!  ----   : ----   : ---------------------------------------------
!fracrefa : real
! ka      : real
! ka_mn2  : real
! selfref : real
! forref  : real
!
! absa    : real
!-----------------------------------------------------------------

      integer(kind=im), parameter :: ng15 = 2

      real(kind=rb) :: fracrefa(ng15,9)
      real(kind=rb) :: ka(9,5,13,ng15) ,absa(585,ng15)
      real(kind=rb) :: ka_mn2(9,19,ng15)
      real(kind=rb) :: selfref(10,ng15)
      real(kind=rb) :: forref(4,ng15)

      equivalence (ka(1,1,1,1),absa(1,1))

      end module rrlw_kg15


      subroutine react(i_node_set, temp1,temp2,
     2     icouple, jcouple,igrp)
!***********************************************************************
!  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 add reaction terms to the Jacobian and the
CD1 residual for each node.
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision
CD2 Date        Programmer       Number   Comments
CD2
CD2 ?           Hari Viswanathan  N/A     Initial  implementation -
CD2                                       broken out from coneq1
CD2                                       in order to
CD2                                       to allow for the calculation
CD2                                       of the Jacobian cross
CD2                                       derivative terms
CD2
CD2 $Log:   /pvcs.config/fehm90/src/react.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:46   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:13:12   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:12:04   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:26:10   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:06:38   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:44:48 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.4   Thu Feb 01 15:41:42 1996   hend
CD2 Added Requirements Traceability
CD2
CD2    Rev 1.3   08/30/95 17:02:28   robinson
CD2 Fixed source term calculation
CD2
CD2    Rev 1.2   08/30/95 13:28:50   robinson
CD2 Fixed problem with dpdp transport with reaction
CD2
CD2    Rev 1.1   04/25/95 10:04:44   llt
CD2 retrieved lost log history information
CD2
CD2    Rev 1.0   01/28/95 14:05:46   llt
CD2 revised reactive transport module
CD2
C**********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  2.3.4 Solute-transport equations
CD3  2.4.6 Multiple, interacting solutes
CD3
C**********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************

      use combi
      use comchem
      use comci
      use comdi
      use comei
      use comgi
      use comfi
      use comrxni
      use davidi
      use comcouple
      use comdti
      use comai
      implicit none

      integer i_node_set
      integer i
      integer mi
      integer mim
      integer matnum
      integer spec_num
      integer icouple
      integer jcouple
      integer ndummy
      integer iz
      integer jmi
      integer neqp1
      integer jmia
      integer nsizea_single
      integer mat
      integer dmatnum
      integer igrp
      integer temp1
      integer temp2
      if(i_node_set.eq.1)then
         matnum = temp1
         spec_num = temp2
      else
         matnum=temp1+n_couple_species(igrp)*2+1
         spec_num = temp2+1
      endif
      ndummy = (i_node_set-1) * neq
      neqp1 = neq + 1
      nsizea_single=(nelm(neqp1)-neqp1)
      dmatnum = matpos(jcouple+ncpnt*(icouple-1))
      if(icns(nsp).eq.1.or.abs(icns(nsp)).eq.2)then
         do i = 1, neq
            mi=i+ndummy+npn
            mim=mi-npn
            iz = i
            jmi=nelmdg(i)
            jmia=jmi-neqp1
            mat = i+ndummy+(dmatnum-1)*n0
            if(icouple.eq.jcouple)then
               bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num))
     2              + rc(mi)
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))
     2              +drdctaq(mat)
            else
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))
     2              +drdctaq(mat)
            endif
         end do
      else
         do i = 1, neq
            mi=i+ndummy+npn
            mim=mi-npn
            iz = i
            jmi=nelmdg(i)
            jmia=jmi-neqp1
            if(icouple.eq.jcouple)then
               bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num))
     2              + rc(mi)
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))
     2              +drdcvap(1,mim)
            else
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))
     2              +drdcvap(icouple,mim)
            endif
         end do
      endif
      end