      SUBROUTINE DT_EVENTB(Ncsy,Irej)

C***********************************************************************
C Treatment of nucleon-nucleon interactions with full two-component    *
C Dual Parton Model.                                                   *
C          NCSY     number of nucleon-nucleon interactions             *
C          IREJ     rejection flag                                     *
C This version dated 14.01.2000 is written by S. Roesler               *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION amnn , amp2 , amtot , amtot2 , diff1 , diff2 ,
     &                 dum , ONE , parrj21 , parrj23 , parrj24 ,
     &                 parrj41 , parrj42 , pp , pp1 , pp2 , ppcms ,
     &                 ppnn , ppsub
      DOUBLE PRECISION ppsuto , pptcms , pptmp , pptot , pptotn ,
     &                 pptsub , psutot , pt , pt1 , pt2 , ptcms , ptnn ,
     &                 ptot , ptot1 , ptot2 , ptotnn , ptsub , ptsuto ,
     &                 pttcms , pttmp
      DOUBLE PRECISION pttsub , TINY10 , xmp , xmt , ZERO
      INTEGER i , iback , iesss1 , iesss2 , ifp1 , ifp2 , ift1 , ift2 ,
     &        ir1 , Irej , irej1 , irej2 , irej3 , iremn1 , iremn2 ,
     &        irjano
      INTEGER isingl , iswsav , jfrg , k , kpron , mo1 , mo2 , mop ,
     &        mop1 , mop2 , mot , mot1 , mot2 , mxdtfr , mxleft ,
     &        mxphfr , nc , Ncsy , ndtusc
      INTEGER nfrg , nleft , nphosc , npje , npymax , npymem
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)

C PYTHIA parameters

      INCLUDE 'inc/pydat1'

C event history

      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'
C! uncomment this line for internal phojet-fragmentation
C #include "dtu_dtevtp.inc"
C particle properties (BAMJET index convention)
      INCLUDE 'inc/dtpart'
C flags for input different options
      INCLUDE 'inc/dtflg1'
C rejection counter
      INCLUDE 'inc/dtrejc'
C properties of interacting particles
      INCLUDE 'inc/dtprta'
C properties of photon/lepton projectiles
      INCLUDE 'inc/dtgpro'
C various options for treatment of partons (DTUNUC 1.x)
C (chain recombination, Cronin,..)
      INCLUDE 'inc/dtchai'
C statistics
      INCLUDE 'inc/dtsta1'
C DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
      INCLUDE 'inc/dtltsu'
C Glauber formalism: collision properties
      INCLUDE 'inc/dtglcp'
C flags for diffractive interactions (DTUNUC 1.x)
      INCLUDE 'inc/dtflg3'
C statistics: double-Pomeron exchange
      INCLUDE 'inc/dtflg2'
C flags for particle decays
      INCLUDE 'inc/dtfrpa'
C nucleon-nucleon event-generator
      INCLUDE 'inc/dtmodl'
C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INCLUDE 'inc/pohdfl'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  initial state parton radiation (internal part)
      INCLUDE 'inc/point6'
C  event debugging information
      INCLUDE 'inc/podebg'
C  general process information
      INCLUDE 'inc/poprcs'

      DIMENSION pp(4) , pt(4) , ptot(4) , pp1(4) , pp2(4) , pt1(4) ,
     &          pt2(4) , ppnn(4) , ptnn(4) , ptotnn(4) , ppsub(4) ,
     &          ptsub(4) , pptcms(4) , pttcms(4) , pptmp(4) , pttmp(4) ,
     &          kpron(15) , isingl(10000)

C initial values for max. number of phojet scatterings and dtunuc chains
C to be fragmented with one pyexec call
      DATA mxphfr , mxdtfr/10 , 100/
#ifdef FOR_FLUKA
C     COMMON / DBGPRE / LDBGPR
C     LOGICAL LDBGPR
#endif
      Irej = 0
C pointer to first parton of the first chain in dtevt common
      NPOint(3) = NHKk + 1
C special flag for double-Pomeron statistics
      IPOpo = 1
C counter for low-mass (DTUNUC) interactions
      ndtusc = 0
C counter for interactions treated by PHOJET
      nphosc = 0

C scan interactions for single nucleon-nucleon interactions
C (this has to be checked here because Cronin modifies parton momenta)
      nc = NPOint(2)
      IF ( Ncsy.GT.10000 ) THEN
         WRITE (LOUt,*) ' DT_EVENTB: NCSY > 10000 ! '
         GOTO 400
      END IF
      DO i = 1 , Ncsy
         isingl(i) = 0
         mop = JMOhkk(1,nc)
         mot = JMOhkk(1,nc+1)
         diff1 = ABS(PHKk(4,mop)-PHKk(4,nc)-PHKk(4,nc+2))
         diff2 = ABS(PHKk(4,mot)-PHKk(4,nc+1)-PHKk(4,nc+3))
         IF ( (diff1.LT.TINY10) .AND. (diff2.LT.TINY10) ) isingl(i) = 1
         nc = nc + 4
      END DO
#ifdef FOR_FLUKA
C     IF ( LDBGPR ) THEN
C        WRITE (77,'(A,I6)')
C    &    ' EVENTB IN:',NHKK
C        CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C        WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C     END IF
#endif
C multiple scattering of chain ends
      IF ( (IP.GT.1) .AND. (MKCron.NE.0) ) CALL DT_CRONIN(1)

C switch to PHOJET-settings for JETSET parameter
      IF ( (IT.GT.1) .AND. (MKCron.NE.0) ) CALL DT_CRONIN(2)
      CALL DT_INITJS(1)
#ifdef FOR_FLUKA
C     IF ( LDBGPR ) THEN
C        WRITE (77,'(A,2I6)')
C    &    ' EVENTB INITJS:',MKCRON,NHKK
C        CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C        WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C     END IF
#endif
C loop over nucleon-nucleon interaction
      nc = NPOint(2)
      DO i = 1 , Ncsy
C
C   pick up one nucleon-nucleon interaction from DTEVT1
C     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
C     ptotnn         - total momentum of the interacting nucleons (cms)
C     pp1,2 / pt1,2  - momenta of the four partons
C     pp    / pt     - total momenta of the proj / targ partons
C     ptot           - total momentum of the four partons
         mop = JMOhkk(1,nc)
         mot = JMOhkk(1,nc+1)
         DO k = 1 , 4
            ppnn(k) = PHKk(k,mop)
            ptnn(k) = PHKk(k,mot)
            ptotnn(k) = ppnn(k) + ptnn(k)
            pp1(k) = PHKk(k,nc)
            pt1(k) = PHKk(k,nc+1)
            pp2(k) = PHKk(k,nc+2)
            pt2(k) = PHKk(k,nc+3)
            pp(k) = pp1(k) + pp2(k)
            pt(k) = pt1(k) + pt2(k)
            ptot(k) = pp(k) + pt(k)
         END DO
C
C-----------------------------------------------------------------------
C   this is a complete nucleon-nucleon interaction
C
         IF ( isingl(i).EQ.1 ) THEN
C
C     initialize PHOJET-variables for remnant/valence-partons
            IHFld(1,1) = 0
            IHFld(1,2) = 0
            IHFld(2,1) = 0
            IHFld(2,2) = 0
            IHFls(1) = 1
            IHFls(2) = 1
            XPSub = 1.D0
            XTSub = 1.D0
C     save current settings of PHOJET process and min. bias flags
            DO k = 1 , 11
               kpron(k) = IPRon(k,1)
            END DO
            iswsav = ISWmdl(2)
C
C     check if forced sampling of diffractive interaction requested
            IF ( ISIngd.LT.-1 ) THEN
               DO k = 1 , 11
                  IPRon(k,1) = 0
               END DO
               IF ( (ISIngd.EQ.-2) .OR. (ISIngd.EQ.-3) ) IPRon(5,1) = 1
               IF ( (ISIngd.EQ.-2) .OR. (ISIngd.EQ.-4) ) IPRon(6,1) = 1
               IF ( ISIngd.EQ.-5 ) IPRon(4,1) = 1
            END IF
C
C     for photons: a direct/anomalous interaction is not sampled
C     in PHOJET but already in Glauber-formalism. Here we check if such
C     an interaction is requested
            IF ( IJProj.EQ.7 ) THEN
C       first switch off direct interactions
               IPRon(8,1) = 0
C       this is a direct interactions
               IF ( IDIrec.EQ.1 ) THEN
                  DO k = 1 , 11
                     IPRon(k,1) = 0
                  END DO
                  IPRon(8,1) = 1
C       this is an anomalous interactions
C         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
               ELSE IF ( IDIrec.EQ.2 ) THEN
                  ISWmdl(2) = 0
               END IF
            ELSE IF ( IDIrec.NE.0 ) THEN
               STOP ' DT_EVENTB: IDIREC > 0 ! '
            END IF
C
C     make sure that total momenta of partons, pp and pt, are on mass
C     shell (Cronin may have srewed this up..)
            CALL DT_MASHEL(pp,pt,PHKk(5,mop),PHKk(5,mot),ppnn,ptnn,ir1)
#ifdef FOR_FLUKA
C           IF ( LDBGPR ) THEN
C              WRITE (77,'(A,4I6,(/,1P,4G23.15))')
C    &         ' EVENTB MASHEL:',I,MOP,MOT,NHKK,PP,PT
C              CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C              WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C           END IF
#endif
            IF ( ir1.NE.0 ) THEN

               IF ( LPRi.GT.4 .AND. IOUlev(1).GT.0 )
     &               WRITE (LOUt,'(1X,A)')
     &               'EVENTB:  mass shell correction rejected'
               GOTO 400
            END IF
C
C     initialize the incoming particles in PHOJET
            IF ( (IP.EQ.1) .AND. (IJProj.EQ.7) ) THEN

               CALL PHO_SETPAR(1,22,0,VIRt)

            ELSE

               CALL PHO_SETPAR(1,IDHkk(mop),0,ZERO)

            END IF
#ifdef FOR_FLUKA
C           IF ( LDBGPR ) THEN
C              WRITE (77,'(A,I6)')
C    &         ' EVENTB SETPAR-1:',NHKK
C              CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C              WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C           END IF
#endif
            CALL PHO_SETPAR(2,IDHkk(mot),0,ZERO)
#ifdef FOR_FLUKA
C           IF ( LDBGPR ) THEN
C              WRITE (77,'(A,I6)')
C    &         ' EVENTB SETPAR-2:',NHKK
C              CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C              WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C           END IF
#endif

C
C     initialize rejection loop counter for anomalous processes
            irjano = 0
 20         irjano = irjano + 1
C
C     temporary fix for ifano problem
            IFAno(1) = 0
            IFAno(2) = 0
C
C     generate complete hadron/nucleon/photon-nucleon event with PHOJET

            CALL PHO_EVENT(2,ppnn,ptnn,dum,irej1)
#ifdef FOR_FLUKA
C           IF ( LDBGPR ) THEN
C              WRITE (77,'(A,2I6,(/,1P,4G23.15))')
C    &         ' EVENTB EVENT:',IREJ1,NHKK,PPNN,PTNN
C              CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C              WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C           END IF
#endif

C
C     for photons: special consistency check for anomalous interactions
            IF ( IJProj.EQ.7 ) THEN
               IF ( irjano.GE.30 ) THEN

                  IF ( LPRi.GT.4 ) WRITE (LOUt,*)
     &                  ' DT_EVENTB: Warning! IRJANO > 30 ' , irjano ,
     &                 IDIrec , NEVhkk
               ELSE IF ( IFAno(1).NE.0 ) THEN
C       here, an anomalous interaction was generated. Check if it
C       was also requested. Otherwise reject this event.
                  IF ( IDIrec.EQ.0 ) GOTO 20
C       here, an anomalous interaction was not generated. Check if it
C       was requested in which case we need to reject this event.
               ELSE IF ( IDIrec.EQ.2 ) THEN
                  GOTO 20
               END IF
            END IF
C
C     copy back original settings of PHOJET process and min. bias flags
            DO k = 1 , 11
               IPRon(k,1) = kpron(k)
            END DO
            ISWmdl(2) = iswsav
C
C     check if PHOJET has rejected this event
            IF ( irej1.NE.0 ) THEN
C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')

               IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,A,I4)')
     &               'EVENTB:  chain system rejected' , IDIrec

               CALL PHO_PREVNT(0)

               GOTO 400
            END IF
C
C     copy partons and strings from PHOJET common back into DTEVT for
C     external fragmentation
            mo1 = nc
            mo2 = nc + 3
C!      uncomment this line for internal phojet-fragmentation
C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
            nphosc = nphosc + 1
            CALL DT_GETPJE(mo1,mo2,ppnn,ptnn,-1,nphosc,irej1)
#ifdef FOR_FLUKA
C           IF ( LDBGPR ) THEN
C              WRITE (77,'(A,2I6,(/,1P,4G23.15))')
C    &         ' EVENTB GETPJE:',NPHOSC,NHKK,PPNN,PTNN
C              CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C              WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C           END IF
#endif
            IF ( irej1.NE.0 ) THEN

               IF ( IOUlev(1).GT.0 .AND. LPRi.GT.4 )
     &               WRITE (LOUt,'(1X,A,I4)')
     &               'EVENTB: chain system rejected 1'
               GOTO 400
            END IF
C
C     update statistics counter
            ICEvtg(IDCh(nc),29) = ICEvtg(IDCh(nc),29) + 1
C
C-----------------------------------------------------------------------
C   this interaction involves "remnants"
C
         ELSE
C
C     total mass of this system
            pptot = SQRT(ptot(1)**2+ptot(2)**2+ptot(3)**2)
            amtot2 = (ptot(4)-pptot)*(ptot(4)+pptot)
            IF ( amtot2.LT.ZERO ) THEN
               amtot = ZERO
            ELSE
               amtot = SQRT(amtot2)
            END IF
C
C     systems with masses larger than elojet are treated with PHOJET
            IF ( amtot.GT.ELOjet ) THEN
C
C     initialize PHOJET-variables for remnant/valence-partons
C       projectile parton flavors and valence flag
               IHFld(1,1) = IDHkk(nc)
               IHFld(1,2) = IDHkk(nc+2)
               IHFls(1) = 0
               IF ( (IDCh(nc).EQ.6) .OR. (IDCh(nc).EQ.7) .OR.
     &              (IDCh(nc).EQ.8) ) IHFls(1) = 1
C       target parton flavors and valence flag
               IHFld(2,1) = IDHkk(nc+1)
               IHFld(2,2) = IDHkk(nc+3)
               IHFls(2) = 0
               IF ( (IDCh(nc).EQ.4) .OR. (IDCh(nc).EQ.5) .OR.
     &              (IDCh(nc).EQ.8) ) IHFls(2) = 1
C       flag signalizing PHOJET how to treat the remnant:
C         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
C         iremn > -1 valence remnant: PHOJET assumes flavors according
C                    to mother particle
               iremn1 = IHFls(1) - 1
               iremn2 = IHFls(2) - 1
C
C     initialize the incoming particles in PHOJET
               IF ( (IP.EQ.1) .AND. (IJProj.EQ.7) ) THEN

                  CALL PHO_SETPAR(1,22,iremn1,VIRt)

               ELSE

                  CALL PHO_SETPAR(1,IDHkk(mop),iremn1,ZERO)

               END IF
#ifdef FOR_FLUKA
C              IF ( LDBGPR ) THEN
C                 WRITE (77,'(A,I6)')
C    &            ' EVENTB SETPAR-12:',NHKK
C                 CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C                 WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C              END IF
#endif
               CALL PHO_SETPAR(2,IDHkk(mot),iremn2,ZERO)
#ifdef FOR_FLUKA
C              IF ( LDBGPR ) THEN
C                 WRITE (77,'(A,I6)')
C    &            ' EVENTB SETPAR-22:',NHKK
C                 CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C                 WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C              END IF
#endif
C
C     calculate Lorentz parameter of the nucleon-nucleon cm-system
               pptotn = SQRT(ptotnn(1)**2+ptotnn(2)**2+ptotnn(3)**2)
               amnn = SQRT((ptotnn(4)-pptotn)*(ptotnn(4)+pptotn))
               BGX = ptotnn(1)/amnn
               BGY = ptotnn(2)/amnn
               BGZ = ptotnn(3)/amnn
               GAM = ptotnn(4)/amnn
C     transform interacting nucleons into nucleon-nucleon cm-system
               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,ppnn(1),ppnn(2),ppnn(3)
     &                        ,ppnn(4),ppcms,pptcms(1),pptcms(2),
     &                        pptcms(3),pptcms(4))
               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,ptnn(1),ptnn(2),ptnn(3)
     &                        ,ptnn(4),ptcms,pttcms(1),pttcms(2),
     &                        pttcms(3),pttcms(4))
C     transform (total) momenta of the proj and targ partons into
C     nucleon-nucleon cm-system
               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,pp(1),pp(2),pp(3),
     &                        pp(4),pptsub,ppsub(1),ppsub(2),ppsub(3),
     &                        ppsub(4))
               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,pt(1),pt(2),pt(3),
     &                        pt(4),pttsub,ptsub(1),ptsub(2),ptsub(3),
     &                        ptsub(4))
C     energy fractions of the proj and targ partons
               XPSub = MIN(ppsub(4)/pptcms(4),ONE)
               XTSub = MIN(ptsub(4)/pttcms(4),ONE)
C**
C testprint
C              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
C    &                        (PPTCMS(2)+PTTCMS(2))**2 +
C    &                        (PPTCMS(3)+PTTCMS(3))**2 )
C              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
C    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
C              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
C    &                        (PPSUB(2)+PTSUB(2))**2 +
C    &                        (PPSUB(3)+PTSUB(3))**2 )
C              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
C    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
C**
C
C     save current settings of PHOJET process and min. bias flags
               DO k = 1 , 11
                  kpron(k) = IPRon(k,1)
               END DO
C     disallow direct photon int. (does not make sense here anyway)
               IPRon(8,1) = 0
C     disallow double pomeron processes (due to technical problems
C     in PHOJET, needs to be solved sometime)
               IPRon(4,1) = 0
C     disallow diffraction for sea-diquarks
               IF ( (IABS(IHFld(1,1)).GT.1100) .AND.
     &              (IABS(IHFld(1,2)).GT.1100) ) THEN
                  IPRon(3,1) = 0
                  IPRon(6,1) = 0
               END IF
               IF ( (IABS(IHFld(2,1)).GT.1100) .AND.
     &              (IABS(IHFld(2,2)).GT.1100) ) THEN
                  IPRon(3,1) = 0
                  IPRon(5,1) = 0
               END IF
C     switch off qelast. vectormeson production for photons,
C     electrons and positrons - implemented to avoid final
C     state particles/resonances from Phojet with Id=81
               IF ( IJProj.EQ.7 ) IPRon(3,1) = 0
C
C     we need massless partons: transform them on mass shell
               xmp = ZERO
               xmt = ZERO
               DO k = 1 , 4
                  pptmp(k) = ppsub(k)
                  pttmp(k) = ptsub(k)
               END DO
               CALL DT_MASHEL(pptmp,pttmp,xmp,xmt,ppsub,ptsub,irej1)
#ifdef FOR_FLUKA
C              IF ( LDBGPR ) THEN
C                 WRITE (77,'(A,4I6,(/,1P,4G23.15))')
C    &            ' EVENTB MASHEL:',I,MOP,MOT,NHKK,PPTMP,PTTMP
C                 CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C                 WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C              END IF
#endif
               ppsuto = SQRT(ppsub(1)**2+ppsub(2)**2+ppsub(3)**2)
               ptsuto = SQRT(ptsub(1)**2+ptsub(2)**2+ptsub(3)**2)
               psutot = SQRT((ppsub(1)+ptsub(1))**2+(ppsub(2)+ptsub(2))
     &                  **2+(ppsub(3)+ptsub(3))**2)
C     total energy of the subsysten after mass transformation
C      (should be the same as before..)
               SECm = SQRT((ppsub(4)+ptsub(4)-psutot)
     &                *(ppsub(4)+ptsub(4)+psutot))
C
C     after mass shell transformation the x_sub - relation has to be
C     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
C
C     The old version was to scale based on the original x_sub and the
C     4-momenta of the subsystem. At very high energy this could lead to
C     "pseudo-cm energies" of the parent system considerably exceeding
C     the true cm energy. Now we keep the true cm energy and calculate
C     new x_sub instead.
C old version  PPTCMS(4) = PPSUB(4)/XPSUB
               pptcms(4) = MAX(pptcms(4),ppsub(4))
               XPSub = ppsub(4)/pptcms(4)
               IF ( IJProj.EQ.7 ) THEN
                  amp2 = PHKk(5,mot)**2
                  ptot1 = SQRT(pptcms(4)**2-amp2)
               ELSE
C???????
                  ptot1 = SQRT((pptcms(4)-PHKk(5,mop))
     &                    *(pptcms(4)+PHKk(5,mop)))
C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
               END IF
C old version  PTTCMS(4) = PTSUB(4)/XTSUB
               pttcms(4) = MAX(pttcms(4),ptsub(4))
               XTSub = ptsub(4)/pttcms(4)
               ptot2 = SQRT((pttcms(4)-PHKk(5,mot))
     &                 *(pttcms(4)+PHKk(5,mot)))
               DO k = 1 , 3
                  pptcms(k) = ptot1*ppsub(k)/ppsuto
                  pttcms(k) = ptot2*ptsub(k)/ptsuto
               END DO
C**
C testprint
C
C     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
C     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
C     pptcms/ pttcms - momenta of the interacting nucleons (cms)
C     pp1,2 / pt1,2  - momenta of the four partons
C
C     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
C     ptot           - total momentum of the four partons (cms, negl. Fermi)
C     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
C
C              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
C    &                        (PPTCMS(2)+PTTCMS(2))**2 +
C    &                        (PPTCMS(3)+PTTCMS(3))**2 )
C              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
C    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
C              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
C    &                        (PPSUB(2)+PTSUB(2))**2 +
C    &                        (PPSUB(3)+PTSUB(3))**2 )
C              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
C    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
C              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
C                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
C                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
C                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
C              ENDIF
C              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
C              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
C              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
C              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
C     transform interacting nucleons into nucleon-nucleon cm-system
C              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
C    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
C    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
C              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
C    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
C    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
C              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
C    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
C    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
C              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
C    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
C    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
C              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
C    &                        (PPNEW2+PTNEW2)**2 +
C    &                        (PPNEW3+PTNEW3)**2 )
C              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
C    &                        (PPNEW4+PTNEW4+PTSTCM) )
C              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
C    &                        (PPSUB2+PTSUB2)**2 +
C    &                        (PPSUB3+PTSUB3)**2 )
C              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
C    &                        (PPSUB4+PTSUB4+PTSTSU) )
C              WRITE(*,*) ' mother cmE :'
C              WRITE(*,*) ETSTCM,ENEWCM
C              WRITE(*,*) ' subsystem cmE :'
C              WRITE(*,*) ETSTSU,ENEWSU
C              WRITE(*,*) ' projectile mother :'
C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
C              WRITE(*,*) ' target mother :'
C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
C              WRITE(*,*) ' projectile subsystem:'
C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
C              WRITE(*,*) ' target subsystem:'
C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
C              WRITE(*,*) ' projectile subsystem should be:'
C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
C    &                    XPSUB*ETSTCM/2.0D0
C              WRITE(*,*) ' target subsystem should be:'
C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
C    &                    XTSUB*ETSTCM/2.0D0
C              WRITE(*,*) ' subsystem cmE should be: '
C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
C**
C
C     generate complete remnant - nucleon/remnant event with PHOJET

               CALL PHO_EVENT(3,pptcms,pttcms,dum,irej1)
#ifdef FOR_FLUKA
C              IF ( LDBGPR ) THEN
C                 WRITE (77,'(A,2I6,(/,1P,4G23.15))')
C    &            ' EVENTB EVENT-2:',IREJ1,NHKK,PPTCMS,PTTCMS
C                 CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C                 WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C              END IF
#endif
C
C     copy back original settings of PHOJET process flags
               DO k = 1 , 11
                  IPRon(k,1) = kpron(k)
               END DO
C
C     check if PHOJET has rejected this event
               IF ( irej1.NE.0 ) THEN

                  IF ( IOUlev(1).GT.0 .AND. LPRi.GT.4 )
     &                  WRITE (LOUt,'(1X,A)')
     &                  'EVENTB:  chain system rejected'

                  IF ( LPRi.GT.4 ) WRITE (LOUt,*) 'XPSUB,XTSUB,SECM ' ,
     &                 XPSub , XTSub , SECm , amtot

                  CALL PHO_PREVNT(0)

                  GOTO 400
               END IF
C
C     copy partons and strings from PHOJET common back into DTEVT for
C     external fragmentation
               mo1 = nc
               mo2 = nc + 3
C!      uncomment this line for internal phojet-fragmentation
C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
               nphosc = nphosc + 1
               CALL DT_GETPJE(mo1,mo2,pp,pt,1,nphosc,irej1)
#ifdef FOR_FLUKA
C              IF ( LDBGPR ) THEN
C                 WRITE (77,'(A,2I6,(/,1P,4G23.15))')
C    &            ' EVENTB GETPJE-2:',NPHOSC,NHKK,PP,PT
C                 CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C                 WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C              END IF
#endif
               IF ( irej1.NE.0 ) THEN

                  IF ( LPRi.GT.4 .AND. IOUlev(1).GT.0 )
     &                  WRITE (LOUt,'(1X,A,I4)')
     &                  'EVENTB: chain system rejected 2'
                  GOTO 400
               END IF
C
C     update statistics counter
               ICEvtg(IDCh(nc),2) = ICEvtg(IDCh(nc),2) + 1
C
C-----------------------------------------------------------------------
C two-chain approx. for smaller systems
C
            ELSE
C
               ndtusc = ndtusc + 1
C   special flag for double-Pomeron statistics
               IPOpo = 0
C
C   pick up flavors at the ends of the two chains
               ifp1 = IDHkk(nc)
               ift1 = IDHkk(nc+1)
               ifp2 = IDHkk(nc+2)
               ift2 = IDHkk(nc+3)
C   ..and the indices of the mothers
               mop1 = nc
               mot1 = nc + 1
               mop2 = nc + 2
               mot2 = nc + 3
               CALL DT_GETCSY(ifp1,pp1,mop1,ifp2,pp2,mop2,ift1,pt1,mot1,
     &                        ift2,pt2,mot2,irej1)
#ifdef FOR_FLUKA
C              IF ( LDBGPR ) THEN
C                 WRITE (77,'(A,2I6)')
C    &            ' EVENTB GETCSY:',IREJ1,NHKK
C                 CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C                 WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C              END IF
#endif
C
C   check if this chain system was rejected
               IF ( irej1.GT.0 ) THEN
                  IF ( IOUlev(1).GT.0 ) THEN

                     IF ( LPRi.GT.4 ) WRITE (LOUt,*)
     &                     'rejected 1 in EVENTB'

                     IF ( LPRi.GT.4 )
     &                     WRITE (LOUt,'(1X,4(I6,4E12.3,/),E12.3)')
     &                    ifp1 , pp1 , ift1 , pt1 , ifp2 , pp2 , ift2 ,
     &                    pt2 , amtot
                  END IF
                  IRHha = IRHha + 1
                  GOTO 400
               END IF
C   the following lines are for sea-sea chains rejected in GETCSY
               IF ( irej1.EQ.-1 ) ndtusc = ndtusc - 1
               ICEvtg(IDCh(nc),1) = ICEvtg(IDCh(nc),1) + 1
            END IF
C
         END IF
C
C     update statistics counter
         ICEvtg(IDCh(nc),0) = ICEvtg(IDCh(nc),0) + 1
C
         nc = nc + 4
C
      END DO
C
C-----------------------------------------------------------------------
C treatment of low-mass chains (if there are any)
C
      IF ( ndtusc.LE.0 ) THEN
C! uncomment this line for internal phojet-fragmentation
C        NPOINT(4) = NHKK+1
         IF ( NPOint(4).LE.NPOint(3) ) NPOint(4) = NHKk + 1
C
C   correct chains of very low masses for possible resonances
      ELSE IF ( IREsco.EQ.1 ) THEN
         CALL DT_EVTRES(irej1)
#ifdef FOR_FLUKA
C           IF ( LDBGPR ) THEN
C              WRITE (77,'(A,2I6)')
C    &         ' EVENTB EVTRES:',IREJ1,NHKK
C              CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C              WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C           END IF
#endif
         IF ( irej1.GT.0 ) THEN

            IF ( LPRi.GT.4 .AND. IOUlev(1).GT.0 ) WRITE (LOUt,*)
     &            'rejected 2a in EVENTB'
            IRRes(1) = IRRes(1) + 1
            GOTO 400
         END IF
C   fragmentation of low-mass chains
C!  uncomment this line for internal phojet-fragmentation
C   (of course it will still be fragmented by DPMJET-routines but it
C    has to be done here instead of further below)
C        CALL DT_EVTFRA(IREJ1)
C        IF (IREJ1.GT.0) THEN
C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
C           IRFRAG = IRFRAG+1
C           GOTO 9999
C        ENDIF
      END IF
C
C-----------------------------------------------------------------------
C new di-quark breaking mechanisms
C
      mxleft = 2
      CALL DT_CHASTA(0)
      IF ( (PDBsea(1).GT.0.0D0) .OR. (PDBsea(2).GT.0.0D0) .OR.
     &     (PDBsea(3).GT.0.0D0) ) THEN
         CALL DT_DIQBRK
#ifdef FOR_FLUKA
C        IF ( LDBGPR ) THEN
C           WRITE (77,'(A,I6)')
C    &       ' EVENTB DIQBRK:',NHKK
C           CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C           WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C        END IF
#endif
         mxleft = 4
      END IF

C     chain fusion
C     WRITE(6,*)' EVENTB: IFUSION before DENSITY,IAPROJ,IATARG',
C    * IFUSION,IP,IT
      IF ( (IFUsion.EQ.1) .AND. (IP.GT.12) .AND. (IT.GT.12) )
     &     CALL DT_DENSITY
#ifdef FOR_FLUKA
C     IF ( LDBGPR ) THEN
C        WRITE (77,'(A,2I6)')
C    &    ' EVENTB DENSITY:',IFUSION,NHKK
C        CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C        WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C     END IF
C
C
C
C     IF ( LDBGPR ) THEN
C        WRITE (77,'(A,I6)')
C    &    ' EVENTB BEF HADRONIZATION:',NHKK
C        CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C        WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C     END IF
#endif
C-----------------------------------------------------------------------
C hadronize this event
C
C   hadronize PHOJET chain systems
      npymax = 0
      npje = nphosc/mxphfr
      IF ( mxphfr.LT.mxleft ) mxleft = 2
      IF ( npje.GT.1 ) THEN
         nleft = nphosc - npje*mxphfr
         DO jfrg = 1 , npje
            nfrg = jfrg*mxphfr
            IF ( (jfrg.EQ.npje) .AND. (nleft.LE.mxleft) ) THEN
               CALL DT_EVTFRG(1,nphosc,npymem,irej1)
               IF ( irej1.GT.0 ) GOTO 200
               nleft = 0
            ELSE
               CALL DT_EVTFRG(1,nfrg,npymem,irej1)
               IF ( irej1.GT.0 ) GOTO 200
            END IF
            IF ( npymem.GT.npymax ) npymax = npymem
         END DO
         IF ( nleft.GT.0 ) THEN
            CALL DT_EVTFRG(1,nphosc,npymem,irej1)
            IF ( irej1.GT.0 ) GOTO 200
            IF ( npymem.GT.npymax ) npymax = npymem
         END IF
      ELSE
         CALL DT_EVTFRG(1,nphosc,npymem,irej1)
         IF ( irej1.GT.0 ) GOTO 200
         IF ( npymem.GT.npymax ) npymax = npymem
      END IF
#ifdef FOR_FLUKA
C     IF ( LDBGPR ) THEN
C        WRITE (77,'(A,5I6)')
C    &   ' EVENTB AFTER PHOJET HADR.:',
C    &   NPJE,NPHOSC,NPYMEM,NPYMAX,NHKK
C        CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C        WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C     END IF
#endif
C
C   check max. filling level of jetset common and
C   reduce mxphfr if necessary
      IF ( npymax.GT.3000 ) THEN
         IF ( npymax.GT.3500 ) THEN
            mxphfr = MAX(1,mxphfr-2)
         ELSE
            mxphfr = MAX(1,mxphfr-1)
         END IF
C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
      END IF
C
C   hadronize DTUNUC chain systems
 100  iback = mxdtfr
      CALL DT_EVTFRG(2,iback,npymem,irej2)
#ifdef FOR_FLUKA
C     IF ( LDBGPR ) THEN
C        WRITE (77,'(A,4I6)')
C    &   ' EVENTB AFTER DTUNUC HADR.:',
C    &   IBACK,NPYMEM,IREJ2,NHKK
C        CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C        WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C     END IF
#endif
      IF ( irej2.LE.0 ) THEN
C
C   check max. filling level of jetset common and
C   reduce mxdtfr if necessary
         IF ( npymem.GT.3000 ) THEN
            IF ( npymem.GT.3500 ) THEN
               mxdtfr = MAX(1,mxdtfr-20)
            ELSE
               mxdtfr = MAX(1,mxdtfr-10)
            END IF
C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
         END IF
C
         IF ( iback.EQ.-1 ) GOTO 100
      END IF
C
C     CALL DT_EVTFRG(1,IREJ1)
C     CALL DT_EVTFRG(2,IREJ2)
 200  IF ( (irej1.GT.0) .OR. (irej2.GT.0) ) THEN

         IF ( LPRi.GT.4 .AND. IOUlev(1).GT.0 ) WRITE (LOUt,*)
     &         'rejected 1 in EVENTB'
         IRFrag = IRFrag + 1
         GOTO 400
      END IF

C    from dpm3304per 24.5.06 (j.r.)

C   j.r.12/01            Fragmentation of fused chains

C     1 change PYTHIA Parameters
      parrj21 = PARj(21)
      parrj23 = PARj(23)
      parrj24 = PARj(24)
      parrj41 = PARj(41)
      parrj42 = PARj(42)
C temporarily standard parameters j.r.5/02
C     PARJ(21)=1.08D0
C     PARJ(23)=0.2D0
C     PARJ(24)=2.D0
      PARj(41) = 0.15D0
C    old before 7.11.6: to be kept if pyptdi is kept the old one:
      PARj(42) = 1.3D0
C    new: only if pyptdi is the new one
C     PARJ(42)=0.40D0
      iesss1 = iesss1 + 1
#ifdef FOR_FLUKA

      IF ( iesss1.LT.3 .AND. LPRi.GT.4 ) WRITE (LOUt,*)
     &      '1 PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)' , PARj(21)
     &     , PARj(23) , PARj(24) , PARj(41) , PARj(42)

      IF ( iesss1.LT.3 .AND. LPRi.GT.4 ) WRITE (LOUt,*)
     &      '1 PARJ(11),PARJ(18),PARJ(21),PARJ(1),PARJ(2),PARJ(3)' ,
     &     PARj(11) , PARj(18) , PARj(21) , PARj(1) , PARj(2) , PARj(3)

      IF ( iesss1.LT.3 .AND. LPRi.GT.4 ) WRITE (LOUt,*)
     &      '1 PARJ(5),PARJ(19)' , PARj(5) , PARj(19)
#endif
 300  iback = mxdtfr
C     IBACK = 10
C     IBACK=1
      iback = 50
      CALL DT_EVTFRG2(2,iback,npymem,irej2)
C     WRITE(6,*)'PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)',
C    *      PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)
C     WRITE(6,*)'DT_EVTFRG2(2,IBACK,NPYMEM,IREJ2) ',IBACK,NPYMEM,IREJ2
#ifdef FOR_FLUKA
C     IF ( LDBGPR ) THEN
C        WRITE (77,'(A,4I6)')
C    &   ' EVENTB AFTER FUSION HADR.:',
C    &   IBACK,NPYMEM,IREJ2,NHKK
C        CALL FLRNOC (ISDRN1,ISDRN2,ISEED1,ISEED2)
C        WRITE(77,'(2X,2Z8)')ISEED1,ISEED2
C     END IF
#endif
      IF ( irej2.LE.0 ) THEN

C   check max. filling level of jetset common and
C   reduce mxdtfr if necessary
         IF ( npymem.GT.3000 ) THEN
            IF ( npymem.GT.3500 ) THEN
               mxdtfr = MAX(1,mxdtfr-20)
            ELSE
               mxdtfr = MAX(1,mxdtfr-10)
            END IF
C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
         END IF
         IF ( iback.EQ.-1 ) GOTO 300
      END IF
C     2  Return to PYTHIA default parameters
      PARj(21) = parrj21
      PARj(23) = parrj23
      PARj(24) = parrj24
      PARj(41) = parrj41
      PARj(42) = parrj42
      iesss2 = iesss2 + 1
#ifdef FOR_FLUKA
      IF ( iesss2.LT.3 ) WRITE (6,*)
     &      ' 2 PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)' , PARj(21)
     &     , PARj(23) , PARj(24) , PARj(41) , PARj(42)
      IF ( iesss2.LT.3 ) WRITE (6,*)
     &      '2 PARJ(11),PARJ(18),PARJ(21),PARJ(1),PARJ(2),PARJ(3)' ,
     &     PARj(11) , PARj(18) , PARj(21) , PARj(1) , PARj(2) , PARj(3)
      IF ( iesss2.LT.3 ) WRITE (6,*) '2 PARJ(5),PARJ(19)' , PARj(5) ,
     &     PARj(19)
#endif
C

C    from dpm3304per 24.5.06 (j.r.)
C
C get final state particles from /DTEVTP/
C! uncomment this line for internal phojet-fragmentation
C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
      IF ( IJProj.NE.7 ) CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,
     &     irej3)
C     IF (IREJ3.NE.0) GOTO 9999

      RETURN

 400  IREvt = IREvt + 1
      Irej = 1
      END SUBROUTINE


Subroutine pymaxi
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  Common /pysubs/msel, msub(200), kfin(2, -40:40), ckin(200)
  Save /pysubs/
  Common /pypars/mstp(200), parp(200), msti(200), pari(200)
  Save /pypars/
  Common /pyint1/mint(400), vint(400)
  Save /pyint1/
  Common /pyint2/iset(200), kfpr(200, 2), coef(200, 20), icol(40, 4, 2)
  Save /pyint2/
  Common /pyint3/xsfx(2, -40:40), isig(1000, 3), sigh(1000)
  Save /pyint3/
  Common /pyint4/widp(21:40, 0:40), wide(21:40, 0:40), wids(21:40, 3)
  Save /pyint4/
  Common /pyint5/ngen(0:200, 3), xsec(0:200, 3)
  Save /pyint5/
  Common /pyint6/proc(0:200)
  Character proc*28
  Save /pyint6/
  Character cvar(4)*4
  Dimension npts(4), mvarpt(200, 4), vintpt(200, 30), sigspt(200), narel(6), wtrel(6), wtmat(6, 6), coefu(6), iaccmx(4), sigsmx(4), sigssm(3)
  Data cvar/'tau ', 'tau''', 'y*  ', 'cth '/
  vint(143) = 1.
  vint(144) = 1.
  xsec(0, 1) = 0.
  Do isub = 1, 200
    If (isub>=91 .And. isub<=95) Then
      xsec(isub, 1) = vint(isub+11)
      If (msub(isub)/=1) Goto 350
      Goto 340
    Else If (isub==96) Then
      If (mint(43)/=4) Goto 350
      If (msub(95)/=1 .And. mstp(81)<=0 .And. mstp(131)<=0) Goto 350
    Else If (isub==11 .Or. isub==12 .Or. isub==13 .Or. isub==28 .Or. isub==53 .Or. isub==68) Then
      If (msub(isub)/=1 .Or. msub(95)==1) Goto 350
    Else
      If (msub(isub)/=1) Goto 350
    End If
    mint(1) = isub
    istsb = iset(isub)
    If (isub==96) istsb = 2
    If (mstp(122)>=2) Write (mstu(11), 1000) isub
    mint(72) = 0
    kfr1 = 0
    If (istsb==1 .Or. istsb==3) Then
      kfr1 = kfpr(isub, 1)
    Else If (isub>=71 .And. isub<=77) Then
      kfr1 = 25
    End If
    If (kfr1/=0) Then
      taur1 = pmas(kfr1, 1)**2/vint(2)
      gamr1 = pmas(kfr1, 1)*pmas(kfr1, 2)/vint(2)
      mint(72) = 1
      mint(73) = kfr1
      vint(73) = taur1
      vint(74) = gamr1
    End If
    If (isub==141) Then
      kfr2 = 23
      taur2 = pmas(kfr2, 1)**2/vint(2)
      gamr2 = pmas(kfr2, 1)*pmas(kfr2, 2)/vint(2)
      mint(72) = 2
      mint(74) = kfr2
      vint(75) = taur2
      vint(76) = gamr2
    End If
    sqm3 = 0.
    sqm4 = 0.
    mint(71) = 0
    vint(71) = ckin(3)
    If (istsb==2 .Or. istsb==4) Then
      If (kfpr(isub,1)/=0) sqm3 = pmas(kfpr(isub,1), 1)**2
      If (kfpr(isub,2)/=0) sqm4 = pmas(kfpr(isub,2), 1)**2
      If (min(sqm3,sqm4)<ckin(6)**2) mint(71) = 1
      If (mint(71)==1) vint(71) = max(ckin(3), ckin(5))
      If (isub==96 .And. mstp(82)<=1) vint(71) = parp(81)
      If (isub==96 .And. mstp(82)>=2) vint(71) = 0.08*parp(82)
    End If
    vint(63) = sqm3
    vint(64) = sqm4
    npts(1) = 2 + 2*mint(72)
    If (mint(43)==1 .And. (istsb==1 .Or. istsb==2)) npts(1) = 1
    npts(2) = 1
    If (mint(43)>=2 .And. (istsb==3 .Or. istsb==4)) npts(2) = 2
    npts(3) = 1
    If (mint(43)==4) npts(3) = 3
    npts(4) = 1
    If (istsb==2 .Or. istsb==4) npts(4) = 5
    ntry = npts(1)*npts(2)*npts(3)*npts(4)
    Do j = 1, 20
      coef(isub, j) = 0.
    End Do
    coef(isub, 1) = 1.
    coef(isub, 7) = 0.5
    coef(isub, 8) = 0.5
    coef(isub, 10) = 1.
    coef(isub, 15) = 1.
    mcth = 0
    mtaup = 0
    cth = 0.
    taup = 0.
    sigsam = 0.
    Call pyklim(1)
    nacc = 0
    Do itry = 1, ntry
      If (mod(itry-1,npts(2)*npts(3)*npts(4))==0) Then
        mtau = 1 + (itry-1)/(npts(2)*npts(3)*npts(4))
        Call pykmap(1, mtau, 0.5)
        If (istsb==3 .Or. istsb==4) Call pyklim(4)
      End If
      If ((istsb==3 .Or. istsb==4) .And. mod(itry-1,npts(3)*npts(4))==0) Then
        mtaup = 1 + mod((itry-1)/(npts(3)*npts(4)), npts(2))
        Call pykmap(4, mtaup, 0.5)
      End If
      If (mod(itry-1,npts(3)*npts(4))==0) Call pyklim(2)
      If (mod(itry-1,npts(4))==0) Then
        myst = 1 + mod((itry-1)/npts(4), npts(3))
        Call pykmap(2, myst, 0.5)
        Call pyklim(3)
      End If
      If (istsb==2 .Or. istsb==4) Then
        mcth = 1 + mod(itry-1, npts(4))
        Call pykmap(3, mcth, 0.5)
      End If
      If (isub==96) vint(25) = vint(21)*(1.-vint(23)**2)
      mint(51) = 0
      Call pyklim(0)
      If (mint(51)==1) Goto 120
      nacc = nacc + 1
      mvarpt(nacc, 1) = mtau
      mvarpt(nacc, 2) = mtaup
      mvarpt(nacc, 3) = myst
      mvarpt(nacc, 4) = mcth
      Do j = 1, 30
        vintpt(nacc, j) = vint(10+j)
      End Do
      Call pysigh(nchn, sigs)
      sigspt(nacc) = sigs
      If (sigs>sigsam) sigsam = sigs
      If (mstp(122)>=2) Write (mstu(11), 1100) mtau, mtaup, myst, mcth, vint(21), vint(22), vint(23), vint(26), sigs
    120 End Do
    If (sigsam==0.) Then
      Write (mstu(11), 1200) isub
      Stop
    End If
    taumin = vint(11)
    taumax = vint(31)
    atau1 = log(taumax/taumin)
    atau2 = (taumax-taumin)/(taumax*taumin)
    If (npts(1)>=3) Then
      atau3 = log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
      atau4 = (atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/gamr1
    End If
    If (npts(1)>=5) Then
      atau5 = log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
      atau6 = (atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/gamr2
    End If
    ystmin = 0.5*log(taumin)
    ystmax = -ystmin
    ayst0 = ystmax - ystmin
    ayst1 = 0.5*(ystmax-ystmin)**2
    ayst3 = 2.*(atan(exp(ystmax))-atan(exp(ystmin)))
    Do ivar = 1, 4
      If (npts(ivar)==1) Goto 230
      If (isub==96 .And. ivar==4) Goto 230
      nbin = npts(ivar)
      Do j1 = 1, nbin
        narel(j1) = 0
        wtrel(j1) = 0.
        coefu(j1) = 0.
        Do j2 = 1, nbin
          wtmat(j1, j2) = 0.
        End Do
      End Do
      Do iacc = 1, nacc
        ibin = mvarpt(iacc, ivar)
        narel(ibin) = narel(ibin) + 1
        wtrel(ibin) = wtrel(ibin) + sigspt(iacc)
        If (ivar==1) Then
          tau = vintpt(iacc, 11)
          wtmat(ibin, 1) = wtmat(ibin, 1) + 1.
          wtmat(ibin, 2) = wtmat(ibin, 2) + (atau1/atau2)/tau
          If (nbin>=3) Then
            wtmat(ibin, 3) = wtmat(ibin, 3) + (atau1/atau3)/(tau+taur1)
            wtmat(ibin, 4) = wtmat(ibin, 4) + (atau1/atau4)*tau/((tau-taur1)**2+gamr1**2)
          End If
          If (nbin>=5) Then
            wtmat(ibin, 5) = wtmat(ibin, 5) + (atau1/atau5)/(tau+taur2)
            wtmat(ibin, 6) = wtmat(ibin, 6) + (atau1/atau6)*tau/((tau-taur2)**2+gamr2**2)
          End If
        Else If (ivar==2) Then
          tau = vintpt(iacc, 11)
          taup = vintpt(iacc, 16)
          taupmn = vintpt(iacc, 6)
          taupmx = vintpt(iacc, 26)
          ataup1 = log(taupmx/taupmn)
          ataup2 = ((1.-tau/taupmx)**4-(1.-tau/taupmn)**4)/(4.*tau)
          wtmat(ibin, 1) = wtmat(ibin, 1) + 1.
          wtmat(ibin, 2) = wtmat(ibin, 2) + (ataup1/ataup2)*(1.-tau/taup)**3/taup
        Else If (ivar==3) Then
          yst = vintpt(iacc, 12)
          wtmat(ibin, 1) = wtmat(ibin, 1) + (ayst0/ayst1)*(yst-ystmin)
          wtmat(ibin, 2) = wtmat(ibin, 2) + (ayst0/ayst1)*(ystmax-yst)
          wtmat(ibin, 3) = wtmat(ibin, 3) + (ayst0/ayst3)/cosh(yst)
        Else
          rm34 = 2.*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2
          rsqm = 1. + rm34
          cthmax = sqrt(1.-4.*vint(71)**2/(taumax*vint(2)))
          cthmin = -cthmax
          If (cthmax>0.9999) rm34 = max(rm34, 2.*vint(71)**2/(taumax*vint(2)))
          acth1 = cthmax - cthmin
          acth2 = log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))
          acth3 = log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))
          acth4 = 1./max(rm34, rsqm-cthmax) - 1./max(rm34, rsqm-cthmin)
          acth5 = 1./max(rm34, rsqm+cthmin) - 1./max(rm34, rsqm+cthmax)
          cth = vintpt(iacc, 13)
          wtmat(ibin, 1) = wtmat(ibin, 1) + 1.
          wtmat(ibin, 2) = wtmat(ibin, 2) + (acth1/acth2)/max(rm34, rsqm-cth)
          wtmat(ibin, 3) = wtmat(ibin, 3) + (acth1/acth3)/max(rm34, rsqm+cth)
          wtmat(ibin, 4) = wtmat(ibin, 4) + (acth1/acth4)/max(rm34, rsqm-cth)**2
          wtmat(ibin, 5) = wtmat(ibin, 5) + (acth1/acth5)/max(rm34, rsqm+cth)**2
        End If
      End Do
      If (mstp(122)>=2) Write (mstu(11), 1300) cvar(ivar)
      msolv = 1
      Do ibin = 1, nbin
        If (mstp(122)>=2) Write (mstu(11), 1400)(wtmat(ibin,ired), ired=1, nbin), wtrel(ibin)
        If (narel(ibin)==0) msolv = 0
      End Do
      If (msolv==0) Then
        Do ibin = 1, nbin
          coefu(ibin) = 1.
        End Do
      Else
        Do ired = 1, nbin - 1
          Do ibin = ired + 1, nbin
            rqt = wtmat(ibin, ired)/wtmat(ired, ired)
            wtrel(ibin) = wtrel(ibin) - rqt*wtrel(ired)
            Do icoe = ired, nbin
              wtmat(ibin, icoe) = wtmat(ibin, icoe) - rqt*wtmat(ired, icoe)
            End Do
          End Do
        End Do
        Do ired = nbin, 1, -1
          Do icoe = ired + 1, nbin
            wtrel(ired) = wtrel(ired) - wtmat(ired, icoe)*coefu(icoe)
          End Do
          coefu(ired) = wtrel(ired)/wtmat(ired, ired)
        End Do
      End If
      coefsu = 0.
      Do ibin = 1, nbin
        coefu(ibin) = max(0., coefu(ibin))
        coefsu = coefsu + coefu(ibin)
      End Do
      If (ivar==1) ioff = 0
      If (ivar==2) ioff = 14
      If (ivar==3) ioff = 6
      If (ivar==4) ioff = 9
      If (coefsu>0.) Then
        Do ibin = 1, nbin
          coef(isub, ioff+ibin) = parp(121)/nbin + (1.-parp(121))*coefu(ibin)/coefsu
        End Do
      Else
        Do ibin = 1, nbin
          coef(isub, ioff+ibin) = 1./nbin
        End Do
      End If
      If (mstp(122)>=2) Write (mstu(11), 1500) cvar(ivar), (coef(isub,ioff+ibin), ibin=1, nbin)
    230 End Do
    Do j = 1, 4
      iaccmx(j) = 0
      sigsmx(j) = 0.
    End Do
    nmax = 0
    Do iacc = 1, nacc
      Do j = 1, 30
        vint(10+j) = vintpt(iacc, j)
      End Do
      Call pysigh(nchn, sigs)
      ieq = 0
      Do imv = 1, nmax
        If (abs(sigs-sigsmx(imv))<1E-4*(sigs+sigsmx(imv))) ieq = imv
      End Do
      If (ieq==0) Then
        Do imv = nmax, 1, -1
          iin = imv + 1
          If (sigs<=sigsmx(imv)) Goto 280
          iaccmx(imv+1) = iaccmx(imv)
          sigsmx(imv+1) = sigsmx(imv)
        End Do
        iin = 1
        280 iaccmx(iin) = iacc
        sigsmx(iin) = sigs
        If (nmax<=1) nmax = nmax + 1
      End If
    End Do
    If (mstp(122)>=2) Write (mstu(11), 1600)
    sigsam = sigsmx(1)
    Do imax = 1, nmax
      iacc = iaccmx(imax)
      mtau = mvarpt(iacc, 1)
      mtaup = mvarpt(iacc, 2)
      myst = mvarpt(iacc, 3)
      mcth = mvarpt(iacc, 4)
      vtau = 0.5
      vyst = 0.5
      vcth = 0.5
      vtaup = 0.5
      Do irpt = 1, 2
        Do ivar = 1, 4
          If (npts(ivar)==1) Goto 310
          If (ivar==1) vvar = vtau
          If (ivar==2) vvar = vtaup
          If (ivar==3) vvar = vyst
          If (ivar==4) vvar = vcth
          If (ivar==1) mvar = mtau
          If (ivar==2) mvar = mtaup
          If (ivar==3) mvar = myst
          If (ivar==4) mvar = mcth
          If (irpt==1) vdel = 0.1
          If (irpt==2) vdel = max(0.01, min(0.05,vvar-0.02,0.98-vvar))
          If (irpt==1) vmar = 0.02
          If (irpt==2) vmar = 0.002
          imov0 = 1
          If (irpt==1 .And. ivar==1) imov0 = 0
          Do imov = imov0, 8
            If (imov==0) Then
              inew = 2
              vnew = vvar
            Else If (imov==1) Then
              inew = 3
              vnew = vvar + vdel
            Else If (imov==2) Then
              inew = 1
              vnew = vvar - vdel
            Else If (sigssm(3)>=max(sigssm(1),sigssm(2)) .And. vvar+2.*vdel<1.-vmar) Then
              vvar = vvar + vdel
              sigssm(1) = sigssm(2)
              sigssm(2) = sigssm(3)
              inew = 3
              vnew = vvar + vdel
            Else If (sigssm(1)>=max(sigssm(2),sigssm(3)) .And. vvar-2.*vdel>vmar) Then
              vvar = vvar - vdel
              sigssm(3) = sigssm(2)
              sigssm(2) = sigssm(1)
              inew = 1
              vnew = vvar - vdel
            Else If (sigssm(3)>=sigssm(1)) Then
              vdel = 0.5*vdel
              vvar = vvar + vdel
              sigssm(1) = sigssm(2)
              inew = 2
              vnew = vvar
            Else
              vdel = 0.5*vdel
              vvar = vvar - vdel
              sigssm(3) = sigssm(2)
              inew = 2
              vnew = vvar
            End If
            If (ivar==1) Then
              vtau = vnew
              Call pykmap(1, mtau, vtau)
              If (istsb==3 .Or. istsb==4) Call pyklim(4)
            End If
            If (ivar<=2 .And. (istsb==3 .Or. istsb==4)) Then
              If (ivar==2) vtaup = vnew
              Call pykmap(4, mtaup, vtaup)
            End If
            If (ivar<=2) Call pyklim(2)
            If (ivar<=3) Then
              If (ivar==3) vyst = vnew
              Call pykmap(2, myst, vyst)
              Call pyklim(3)
            End If
            If (istsb==2 .Or. istsb==4) Then
              If (ivar==4) vcth = vnew
              Call pykmap(3, mcth, vcth)
            End If
            If (isub==96) vint(25) = vint(21)*(1.-vint(23)**2)
            Call pysigh(nchn, sigs)
            sigssm(inew) = sigs
            If (sigs>sigsam) sigsam = sigs
            If (mstp(122)>=2) Write (mstu(11), 1700) imax, ivar, mvar, imov, vnew, vint(21), vint(22), vint(23), vint(26), sigs
          End Do
        310 End Do
      End Do
      If (imax==1) sigs11 = sigsam
    End Do
    xsec(isub, 1) = 1.05*sigsam
    340 If (isub/=96) xsec(0, 1) = xsec(0, 1) + xsec(isub, 1)
  350 End Do
  If (mstp(122)>=1) Then
    Write (mstu(11), 1800)
    Write (mstu(11), 1900)
    Do isub = 1, 200
      If (msub(isub)/=1 .And. isub/=96) Goto 360
      If (isub==96 .And. mint(43)/=4) Goto 360
      If (isub==96 .And. msub(95)/=1 .And. mstp(81)<=0) Goto 360
      If (msub(95)==1 .And. (isub==11 .Or. isub==12 .Or. isub==13 .Or. isub==28 .Or. isub==53 .Or. isub==68)) Goto 360
      Write (mstu(11), 2000) isub, proc(isub), xsec(isub, 1)
    360 End Do
    Write (mstu(11), 2100)
  End If
  Return
  1000 Format (/1X, 'Coefficient optimization and maximum search for ', 'subprocess no', I4/1X, 'Coefficient modes     tau', 10X, 'y*', 9X, 'cth', 9X, 'tau''', 7X, 'sigma')
  1100 Format (1X, 4I4, F12.8, F12.6, F12.7, F12.8, 1P, E12.4)
  1200 Format (1X, 'Error: requested subprocess ', I3, ' has vanishing ', 'cross-section.'/1X, 'Execution stopped!')
  1300 Format (1X, 'Coefficients of equation system to be solved for ', A4)
  1400 Format (1X, 1P, 7E11.3)
  1500 Format (1X, 'Result for ', A4, ':', 6F9.4)
  1600 Format (1X, 'Maximum search for given coefficients'/2X, 'MAX VAR ', 'MOD MOV   VNEW', 7X, 'tau', 7X, 'y*', 8X, 'cth', 7X, 'tau''', 7X, 'sigma')
  1700 Format (1X, 4I4, F8.4, F11.7, F9.3, F11.6, F11.7, 1P, E12.4)
  1800 Format (/1X, 8('*'), 1X, 'PYMAXI: summary of differential ', 'cross-section maximum search', 1X, 8('*'))
  1900 Format (/11X, 58('=')/11X, 'I', 38X, 'I', 17X, 'I'/11X, 'I  ISUB  ', 'Subprocess name', 15X, 'I  Maximum value  I'/11X, 'I', 38X, 'I', 17X, 'I'/11X, 58('=')/11X, 'I', 38X, 'I', 17X, 'I')
  2000 Format (11X, 'I', 2X, I3, 3X, A28, 2X, 'I', 2X, 1P, E12.4, 3X, 'I')
  2100 Format (11X, 'I', 38X, 'I', 17X, 'I'/11X, 58('='))
End Subroutine pymaxi


MODULE PRMTRS_STMAS_CLOUD

  ! LAPS PARAMETERS
  CHARACTER*9          :: LAPSAST            ! LAPS ASCII TIME
  INTEGER              :: LAPSI4T            ! LAPS I4TIME
  INTEGER              :: ICYCLE             ! LAPS CYCLE TIME

  REAL                 :: RMISSING           ! LAPS DEFAULT MISSING VALUE (YUANFU)
  REAL                 :: BADSFCDT           ! LAPS DEFAULT BAD SURFACE (YUANFU)
  REAL    ,ALLOCATABLE :: LATITUDE(:,:)      ! LAPS LATITUDE OF THE GRID (YUANFU)
  REAL    ,ALLOCATABLE :: LONGITUD(:,:)      ! LAPS LONGITUDE OF THE GRID (YUANFU)
  REAL    ,ALLOCATABLE :: TOPOGRPH(:,:)      ! LAPS LONGITUDE OF THE GRID (YUANFU)
  ! REAL    ,ALLOCATABLE :: LAPSRADW(:)        ! LAPS RADIAL WIND (YUANFU)
  REAL    ,ALLOCATABLE :: Z_FCSTGD(:)        ! VERTICAL LEVEL OF MODEL OR LAPS

  ! END OF LAPS PARAMETERS.

  ! GPS PROCESSING PARAMETERS:
  ! SPECIFIC GAS CONSTANT FOR WATER VAPOR:
  REAL    ,  PARAMETER :: RV_GAS=461
  ! COEFFICIENTS OF REFRACTIVITY AT MICROWAVE FREQUENCIES:
  REAL    ,  PARAMETER :: K2_RFC=22.1
  REAL    ,  PARAMETER :: K3_RFC=373900

  ! BUFR PARAMETERS:
  REAL    ,  PARAMETER :: BUFRMISS = 10.0E10 ! MISSING VALUE IN REAL FOR BUFR DATA
  REAL    ,  PARAMETER :: BADFLAG = -999.9   ! MISSING VALUE

  INTEGER ,  PARAMETER :: MAXDIMS=4          ! NUMBER OF TOTAL DIMENSION
  INTEGER ,  PARAMETER :: TMGOBS_CHANNEL=32  ! CHANNEL FOR TMG FILE
  INTEGER ,  PARAMETER :: PIGOBS_CHANNEL=33  ! CHANNEL FOR TMG FILE
  INTEGER              :: BGTHOBS            ! NOT USE BACKGROUND UNTIL NOBSGRID LESS THAN BGTHOBS
  INTEGER              :: GRDLEVL            ! GRID LEVEL
  INTEGER              :: NUMGRID(MAXDIMS)   ! NUMBER OF GRID FOR EVERY DIMENSION
  INTEGER              :: INIGRID(MAXDIMS)   ! INITIAL NUMBER OF GRID FOR EVERY DIMENSION
  INTEGER              :: MAXGRID(MAXDIMS)   ! MAX NUMBER OF GRID FOR EVERY DIMENSION
  INTEGER              :: NTMPGRD(MAXDIMS)   ! NUMBER OF OLD GRID FOR EVERY DIMENSION
  INTEGER              :: FCSTGRD(MAXDIMS)   ! NUMBER OF OLD GRID FOR EVERY DIMENSION
  INTEGER              :: NUMDIMS            ! NUMBER OF DIMENSION VALID
  INTEGER              :: NGPTOBS            ! NUMBER OF GRID POINT PER OBSERVATION
  INTEGER              :: NUMSTAT            ! NUMBER OF STATE
  INTEGER              :: NALLOBS            ! NUMBER OF TOTAL OBSERVATION VALID
  INTEGER ,ALLOCATABLE :: NOBSTAT(:)         ! NUMBER OF VARIETY OF OBSERVATION VALID
  INTEGER              :: NUMVARS            ! NUMBER OF TOTAL CONTROL VARIABLES VALID
  INTEGER              :: IFBKGND            ! WHETHER USE BACKGROUND OR NOT, 1 IS YES, 0 IS NOT
  INTEGER              :: IFBOUND            ! WHETHER USE BOUND OR NOT, 1 IS YES, 0 IS NOT
  INTEGER              :: IFPCDNT            ! WHETHER USE PURE PRESSURE COORDINATE, 1 IS YES, 0 IS NOT
  INTEGER              :: IF_TEST            ! WHETHER RUN FOR TEST CASE, 1 IS FOR THE TEST CASE, ADDED BY ZHONGJIE HE
  INTEGER              :: FNSTGRD            ! THE FINEST GRID LEVEL
  INTEGER              :: IFREPET            ! WHETHERE RUN THE MUTIGRID FRAME IN MONOTONOUS OR REPEATEDLY, 0 FOR MONOTONOUS, 1 FOR REPEATEDLY
  INTEGER              :: ITREPET            ! THE TIMES TO REPEAT

  REAL    ,ALLOCATABLE :: PENAL0X(:)         ! INITIAL X DIRECTION PENALTY COEFFICENT
  REAL    ,ALLOCATABLE :: PENAL0Y(:)         ! INITIAL Y DIRECTION PENALTY COEFFICENT
  REAL    ,ALLOCATABLE :: PENAL0Z(:)         ! INITIAL Z DIRECTION PENALTY COEFFICENT
  REAL    ,ALLOCATABLE :: PENAL0T(:)         ! INITIAL T DIRECTION PENALTY COEFFICENT
  REAL    ,ALLOCATABLE :: PENAL_X(:)         ! X DIRECTION PENALTY COEFFICENT
  REAL    ,ALLOCATABLE :: PENAL_Y(:)         ! Y DIRECTION PENALTY COEFFICENT
  REAL    ,ALLOCATABLE :: PENAL_Z(:)         ! Z DIRECTION PENALTY COEFFICENT
  REAL    ,ALLOCATABLE :: PENAL_T(:)         ! T DIRECTION PENALTY COEFFICENT
  REAL                 :: PNLT0PU            ! INITIAL GEOSTROPHIC BALANCE PENALTY COEFFICENT, FOR P AND U
  REAL                 :: PNLT0PV            ! INITIAL GEOSTROPHIC BALANCE PENALTY COEFFICENT, FOR P AND V
  REAL                 :: PNLT_PU            ! GEOSTROPHIC BALANCE PENALTY COEFFICENT, FOR P AND U
  REAL                 :: PNLT_PV            ! GEOSTROPHIC BALANCE PENALTY COEFFICENT, FOR P AND V
  REAL                 :: GRDSPAC(MAXDIMS)   ! GRID SPACING
  REAL                 :: ORIPSTN(MAXDIMS)   ! ORIGINAL POSITION OF THE STUDY DOMAIN
  REAL                 :: COSTFUN            ! COST FUNCTION
  REAL    ,ALLOCATABLE :: GRADINT(:,:,:,:,:) ! GRADIENT OF COST FUNCTION
  CHARACTER(LEN=100)   :: OBSFILE            ! OBSERVATION FILE NAME

  INTEGER              :: COSSTEP            ! THE ITERATE STEPS BEFORE MIDDLE GRID LEVEL
  INTEGER              :: MIDGRID            ! MIDDLE GRID LEVEL WHERE THE ITERATE STEP CHANGED
  INTEGER              :: FINSTEP            ! THE ITERATE STEPS AFTER MIDDLE GRID LEVEL

  INTEGER              :: U_CMPNNT           ! U COMPONENT INDEX
  INTEGER              :: V_CMPNNT           ! V COMPONENT INDEX
  INTEGER              :: W_CMPNNT           ! W COMPONENT INDEX
  INTEGER              :: PRESSURE           ! PRESSURE INDEX
  INTEGER              :: TEMPRTUR           ! TEMPERATURE INDEX
  INTEGER              :: HUMIDITY           ! SPECIFIC HUMIDITY INDEX
!added by shuyuan 20100721 for radar reflectivity
  INTEGER              :: ROUR_CMPNNT        ! DENSITY*RAIN WATER MIXING RATIO
  INTEGER              :: ROUS_CMPNNT        ! DENSITY*SNOW WATER MIXING RATIO
!
  INTEGER              :: XSL                ! X COORDINATE INDEX
  INTEGER              :: YSL                ! Y COORDINATE INDEX
  INTEGER              :: PSL                ! PRESSURE INDEX
  INTEGER              :: CSL                ! CORIOLIS FORCE INDEX
  INTEGER              :: DSL                ! DENSITY INDEX

  ! INTEGER ,ALLOCATABLE :: IDXRADWN(:,:)      ! GRID INDICES OF RADIAL WIND

  REAL                 :: XYTRANS            ! COEFFICIENT USED TO TRANSLATE THE X AND Y COORDINATE TO METERS
  REAL                 :: Z_TRANS            ! COEFFICIENT USED TO TRANSLATE THE Z COORDINATE TO METERS

  REAL    ,ALLOCATABLE :: WWW(:,:,:,:)       ! W COMPONENT
  REAL    ,ALLOCATABLE :: XXX(:,:)           ! DISTANCE OF HORIZONTAL DIMENSION 1
  REAL    ,ALLOCATABLE :: YYY(:,:)           ! DISTANCE OF HORIZONTAL DIMENSION 2
  REAL    ,ALLOCATABLE :: ZZZ(:,:,:,:)       ! HEIGHT OF GENERAL VERTICAL COORDINATE
  REAL    ,ALLOCATABLE :: PPP(:)             ! PRESSURE VERTICAL COORDINATE
  REAL    ,ALLOCATABLE :: COR(:,:)           ! CORIOLIS FREQUENCY
  REAL    ,ALLOCATABLE :: DEG(:,:)           ! DIRECTION ANGLE
  REAL    ,ALLOCATABLE :: DEN(:,:,:,:)       ! DENSITY
  REAL    ,ALLOCATABLE :: SCL(:)             ! SCALING THE PHYSICAL VARIABLE
  REAL    ,ALLOCATABLE :: SL0(:)             ! DEFAULT SCALING THE PHYSICAL VARIABLE
  REAL                 :: SCP(5)             ! SCALING XXX,YYY,ZZZ OR PPP,COR,DEN
  REAL                 :: ORIVTCL
  REAL    ,ALLOCATABLE :: XX0(:,:)           ! DISTANCE OF HORIZONTAL DIMENSION 1
  REAL    ,ALLOCATABLE :: YY0(:,:)           ! DISTANCE OF HORIZONTAL DIMENSION 2
  REAL    ,ALLOCATABLE :: ZZ0(:,:,:,:)       ! HEIGHT OF GENERAL VERTICAL COORDINATE
  REAL    ,ALLOCATABLE :: ZZB(:)       ! SIGMA LEVEL FOR VERTICAL COORDINATE
  REAL    ,ALLOCATABLE :: PP0(:)             ! PRESSURE VERTICAL COORDINATE
  REAL    ,ALLOCATABLE :: PPM(:)             ! MULTIGRID PRESSURE VERTICAL COORDINATE
  REAL    ,ALLOCATABLE :: CR0(:,:)           ! CORIOLIS FREQUENCY
  REAL    ,ALLOCATABLE :: DG0(:,:)           ! DIRECTION ANGLE
  REAL    ,ALLOCATABLE :: DN0(:,:,:,:)       ! DENSITY
! FOR OBSERVATION
  REAL                 :: OBSRADAR           ! THE OBSERVATION RATIO OF CONVENTION TO RADAR DATA
  REAL                 :: OBS_SFMR           ! THE OBSERVATION RATIO OF CONVENTION TO SFMR DATA
  REAL                 :: OBSREF           ! THE OBSERVATION RATIO OF REF
  REAL    ,ALLOCATABLE :: OBSPOSTN(:,:)      ! COORDINATE OF OBSERVATION POINT
  REAL    ,ALLOCATABLE :: OBSCOEFF(:,:)      ! INTERPOLATION COEFFICENT
  INTEGER ,ALLOCATABLE :: OBSIDXPC(:,:)      ! INDEX OF EVERY NODE PER CELL
  INTEGER ,ALLOCATABLE :: OBSSTATE(:)        ! NUMBER OF OBSERVATION FOR EVERY STATE
  REAL    ,ALLOCATABLE :: OBSVALUE(:)        ! OBSERVATION VALUE
  REAL    ,ALLOCATABLE :: OBSERROR(:)        ! OBSERVATION ERROR
  REAL    ,ALLOCATABLE :: OBSEINF1(:)        ! OBSERVATION EXTRA INFORMATION 1
  REAL    ,ALLOCATABLE :: OBSEINF2(:)        ! OBSERVATION EXTRA INFORMATION 2
  REAL    ,ALLOCATABLE :: OBSEINF3(:)        ! OBSERVATION EXTRA INFORMATION 3

  ! GPSMET WETDELAY DATA:
  INTEGER, PARAMETER :: MAX_GPS = 5000		! TEMPORARILY HARD CODED  !!changefrom 2000 to 5000 20100525 liu
  INTEGER :: NUM_GPS,I4T_GPS			! I4T_GPS: I4TIME OF Jan 1, 1970
  REAL    :: GPS_XYT(3,MAX_GPS),GPS_ELV(MAX_GPS),GPS_TIM(MAX_GPS), &
             GPS_ERR(MAX_GPS),GPS_TPW(MAX_GPS),GPS_WET(MAX_GPS)

! FOR GRID POINT VARIABLE
  REAL    ,ALLOCATABLE :: GRDBKGD0(:,:,:,:,:)! GRID BACKGROUND VALUE
  REAL    ,ALLOCATABLE :: GRDBKGND(:,:,:,:,:)! GRID BACKGROUND VALUE
  REAL    ,ALLOCATABLE :: GRDANALS(:,:,:,:,:)! GRID ANALYSIS VALUE
  REAL    ,ALLOCATABLE :: TMPANALS(:,:,:,:,:)! GRID ANALYSIS VALUE

  REAL    ,ALLOCATABLE :: WWWOUT(:,:,:,:)    ! W COMPONENT FOR OUTPUT
  REAL    ,ALLOCATABLE :: DIFFTOUT(:,:,:,:,:)! GRID ANALYSIS VALUE FOR OUTPUR
  REAL    ,ALLOCATABLE :: Z_MAXGID(:)        ! VERTICAL LEVEL OF FINEST ANALYSIS GRID

  REAL                 :: PNLT0HY            ! INITIAL HYDROSTATIC CONDITION PENALTY COEFFICENT. ADDIED BY ZHONGJIE HE
  REAL                 :: PNLT_HY            ! HYDROSTATIC CONDITION PENALTY COEFFICENT. ADDIED BY ZHONGJIE HE
  REAL                 :: TAUL_HY            ! REDUCTION COEFFICENT OF HYDROSTATIC CONDITION PENALTY TERM, ADDIED BY ZHONGJIE HE
  REAL                 :: ENDHYLV            ! THE GRID LEVEL AFTER WHICH THE HYDROSTATIC CONDITION PENALTY TERM IS OMMITTED. ADDED BY ZHONGJIE HE
  REAL                 :: ENDGSLV            ! THE GRID LEVEL AFTER WHICH THE GEOSTROPHIC BALANCE PENALTY TERM IS OMMITTED. ADDED BY ZHONGJIE HE
  REAL                 :: LIMIT_3            ! THE LIMITATION OF HEIGHT TO DECIDE IN WHICH RANGE THE OBSERVATION IS AVIABLE. ADDED BY ZHONGJIE HE
  REAL                 :: LIMIT_4            ! THE LIMITATION OF TIME TO DECIDE IN WHICH RANGE THE OBSERVATION IS AVIABLE. ADDED BY ZHONGJIE HE

  ! ANALYSIS DOMAIN BY YUANFU XIE:
  INTEGER              :: ITIME2(2)          ! ANALYSIS TIME WINDOW

!RUIXIA LIU ADD 20120321
  REAL    ,ALLOCATABLE :: AMSUA(:,:,:,:)
  REAL    ,ALLOCATABLE :: T_SFC_0(:,:,:)
  REAL    ,ALLOCATABLE :: AMSUAGRD(:,:,:,:)  ! SATELLITE MULTIGRID POSITION
  REAL    ,ALLOCATABLE :: T_SFC_GRD(:,:,:)
  REAL    ,ALLOCATABLE :: P_lyr(:)
  REAL    ,ALLOCATABLE :: ozn_lyr(:)
  REAL    ,ALLOCATABLE :: P_lvl(:)
  REAL    ,ALLOCATABLE :: T_SFC(:,:)
  REAL    ,ALLOCATABLE :: PPP1(:)             ! PRESSURE VERTICAL COORDINATE
  REAL    ,ALLOCATABLE :: rad(:,:,:,:)
  REAL    ,ALLOCATABLE :: ja(:,:,:,:,:)
  REAL    ,ALLOCATABLE :: T_lyr(:,:,:)
  REAL    ,ALLOCATABLE :: Q_lyr(:,:,:)
  REAL  :: CMAG
  INTEGER  :: INUM2
  CHARACTER(LEN=100)   :: SAT_DA_USE
  CHARACTER(LEN=200)   :: Co_Path
  CHARACTER(LEN=100)   :: Sat_Data_Path(2)   ! ADD AMSU-B BY YUANFU FEB 2013
  CHARACTER(LEN=100)   :: Moist_Unit(2)   ! ADD FOR AMSU-A/B BY YUANFU FEB 2013
  INTEGER  :: NCHBEG,NCHEND
  INTEGER  :: NAMSUB ! YUANFU ADDED FOR COUNTING NUMBER AMSU-B OBS
  INTEGER  ,ALLOCATABLE  :: AMSUID(:,:)
  INTEGER  :: AMSUA_CHANNELS_USED(15),AMSUB_CHANNELS_USED(5) ! YUANFU ADDED FOR CONTROLING AMSU DATA
  REAL  ,ALLOCATABLE :: T_SFC_BKG0(:,:,:)
  REAL    ,ALLOCATABLE :: T_lyr1(:,:,:)
  REAL    ,ALLOCATABLE :: Q_lyr1(:,:,:)
  REAL    ,ALLOCATABLE ::  T_SFC1(:,:)
  REAL    ,ALLOCATABLE :: PPP2(:)
  REAL OZN_lyr1(41)
  REAL  ,  ALLOCATABLE :: rad1(:,:,:,:)
  REAL    ,ALLOCATABLE :: ja1(:,:,:,:,:)
  REAL  ,  ALLOCATABLE :: RAD_AMSUB(:,:,:,:)
  REAL    ,ALLOCATABLE :: JAC_AMSUB(:,:,:,:,:)
  REAL    ,ALLOCATABLE :: P_lvl1(:)
  REAL    ,ALLOCATABLE :: LND(:,:)
  REAL    ,ALLOCATABLE :: LND0(:,:)
  REAL    ,ALLOCATABLE :: LNDGRD(:,:)
  REAL    ,ALLOCATABLE :: LANDTYPE(:)
  REAL    ,ALLOCATABLE :: LNDTY0(:)
!END RUIXIA LIU ADD 20120321

  ! YUANFU XIE ADDS DATA STRUCTURES FOR SATELLITE DATA:
  TYPE SATELLITE_OBS
    INTEGER :: NUMPRO,NUMCHS  ! NUMBER OF PROFILES AND CHANNELS
    INTEGER, ALLOCATABLE :: GRDIDX(:,:)    ! HORIZONTAL GRID LOCATIONS
    INTEGER, ALLOCATABLE :: LNDCVR(:)      ! LAND COVERAGE: LAND:1 WATER:0
    INTEGER, ALLOCATABLE :: LNDTYP(:)      ! LAND TYPE: CRTM LAND OR WATER TYPE
    REAL, ALLOCATABLE    :: SATVAL(:,:)    ! OBSERVED SATELLITE VALUES: CHANNELS X PROFILES
    REAL, ALLOCATABLE    :: ANGLES(:,:)    ! SCAN & ZENITH ANGLES: 4 X PROFILES
                                           ! (LOCAL & SOLAR ANGLES)
  END TYPE SATELLITE_OBS

  TYPE(SATELLITE_OBS) :: AMSUB(3)          ! YUANFU ADDED AMSUB FEB 2013, MAX 3 TIME FRAME NOW
  TYPE(SATELLITE_OBS) :: AMSUBM(3)         ! YUANFU ADDED AMSUB FOR A MULTIGRID LEVEL FEB 2013, MAX 3 TIME FRAME NOW

CONTAINS

!=================================================================================
!>
!! THIS ROUTINE INITIALIES A SATELLITE OBSERVATION DATA STRUCTURE.
!! 1. ALLOCATE MEMORY;
!! 2. ASSIGN VALUES.
!!
!! \history \n
!! CREATION: MAR. 2013 \n
!! AUTHOR  : YUANFU XIE AT NOAA/ESRL/GSD
!
!=================================================================================
SUBROUTINE SATOBS_INIT(SAT_OBS,NUM_PRO,NUM_CHS,GRD_IDX,LND_CVR,LND_TYP,SAT_VAL,SAT_ANG)

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: NUM_PRO,NUM_CHS,GRD_IDX(2,NUM_PRO)
  INTEGER, INTENT(IN) :: LND_CVR(NUM_PRO),LND_TYP(NUM_PRO)
  REAL,    INTENT(IN) :: SAT_VAL(NUM_CHS,NUM_PRO),SAT_ANG(4,NUM_PRO)

  TYPE(SATELLITE_OBS) :: SAT_OBS

  ! LOCAL VARIABLES:
  INTEGER :: IP,ISTATUS

  ! ALLOCATE:
  ALLOCATE(SAT_OBS%GRDIDX(2,NUM_PRO),SAT_OBS%LNDCVR(NUM_PRO),SAT_OBS%LNDTYP(NUM_PRO), &
           SAT_OBS%SATVAL(NUM_CHS,NUM_PRO),SAT_OBS%ANGLES(4,NUM_PRO), STAT=ISTATUS)

  SAT_OBS%NUMPRO = NUM_PRO
  SAT_OBS%NUMCHS = NUM_CHS

  DO IP=1,NUM_PRO
    SAT_OBS%GRDIDX(:,IP) = GRD_IDX(:,IP)
    SAT_OBS%LNDCVR(IP) = LND_CVR(IP)
    SAT_OBS%LNDTYP(IP) = LND_TYP(IP)
    SAT_OBS%SATVAL(:,IP) = SAT_VAL(:,IP)
    SAT_OBS%ANGLES(:,IP) = SAT_ANG(:,IP)
  ENDDO

END SUBROUTINE SATOBS_INIT

!=================================================================================
!>
!! THIS ROUTINE PROJECTS A SATELLITE OBSERVATION DATA STRUCTURE ON TO ONE OVER A
!! FINER RESOLUTION.
!!
!! \HISTORY \N
!! CREATION: MAR. 2013
!!
!! \AUTHOR: YUANFU XIE AT NOAA/ESRL/GSD
!
!=================================================================================
SUBROUTINE SATOBS_PROJ(SATOBS1,SATOBS2,LEVEL,IFLAG)

  IMPLICIT NONE

  INTEGER, INTENT(IN)  :: LEVEL
  INTEGER, INTENT(OUT) :: IFLAG
  TYPE(SATELLITE_OBS), INTENT(IN)  :: SATOBS1
  TYPE(SATELLITE_OBS), INTENT(OUT) :: SATOBS2

    ! LOCAL VARIABLES:
  INTEGER :: IP,ISTATUS,IBASE
  REAL    :: SQRT

  IF (LEVEL .LE. 0) THEN
    IFLAG = 0
    PRINT*,'NO PROJECTION IS NEEDED'
    RETURN
  ENDIF
  IBASE = 2**(LEVEL-1)

  SATOBS2%NUMCHS = SATOBS1%NUMCHS
  SATOBS2%NUMPRO = SATOBS1%NUMPRO ! WORST CASE SCENARIO: PROJECTION HAS ALL OBS

  ! ALLOCATE:
  ALLOCATE(SATOBS2%GRDIDX(2,SATOBS2%NUMPRO),SATOBS2%LNDCVR(SATOBS2%NUMPRO), &
           SATOBS2%LNDTYP(SATOBS2%NUMPRO),SATOBS2%ANGLES(4,SATOBS2%NUMPRO), &
           SATOBS2%SATVAL(SATOBS2%NUMCHS,SATOBS2%NUMPRO), STAT=ISTATUS)

  SATOBS2%NUMPRO = 0
  DO IP=1,SATOBS1%NUMPRO
    IF (MOD(SATOBS1%GRDIDX(1,IP)-1,IBASE) .EQ. 0 .AND. &
        MOD(SATOBS1%GRDIDX(2,IP)-1,IBASE) .EQ. 0) THEN
      SATOBS2%NUMPRO = SATOBS2%NUMPRO + 1

      SATOBS2%GRDIDX(:,SATOBS2%NUMPRO) = (SATOBS1%GRDIDX(:,IP)-1)/(2**(LEVEL-1))+1
      SATOBS2%LNDCVR(SATOBS2%NUMPRO) = SATOBS1%LNDCVR(IP)
      SATOBS2%LNDTYP(SATOBS2%NUMPRO) = SATOBS1%LNDTYP(IP)
      SATOBS2%SATVAL(:,SATOBS2%NUMPRO) = SATOBS1%SATVAL(:,IP)
      SATOBS2%ANGLES(:,SATOBS2%NUMPRO) = SATOBS1%ANGLES(:,IP)
    ENDIF
  ENDDO

  IFLAG = 1

END SUBROUTINE SATOBS_PROJ

!=================================================================================
!>
!! THIS	FOLLOWING ROUTINE IS TO DEALLOCATE A SATELLITE_OBS DATA TYPE VARIABLE.
!!
!! \HISTORY \N
!! CREATION: MAR. 2013 \N
!! \AUTHOR: YUANFU XIE AT NOAA/ESRL
!
!=================================================================================

SUBROUTINE SATOBS_DEAD(SATOBS)

  TYPE(SATELLITE_OBS) :: SATOBS

  ! LOCAL VARIABLES:
  INTEGER :: ISTATUS

  SATOBS%NUMPRO = 0
  SATOBS%NUMCHS = 0

  DEALLOCATE(SATOBS%GRDIDX,SATOBS%LNDCVR,SATOBS%LNDTYP,SATOBS%SATVAL,SATOBS%ANGLES, &
             STAT=ISTATUS)

END SUBROUTINE SATOBS_DEAD

END MODULE PRMTRS_STMAS_CLOUD


program Do_While_Loop
    implicit none
    INTEGER :: a
    a = 1

    !Syntax:
    ! do while(condition)
    !     statements
    !     ..........
    !     ..........
    !     ..........
    !     ..........
    ! end do

    print *, "Number from 1 to 10"
    ! .le. mean less than or equal to
    do while (a .le. 10)
        print *, a
        a = a + 1
    end do

end program Do_While_Loop


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!    subroutine cm5mod: original subroutine for calculation of CM5 charges
!
!    part of QMDFF
!
subroutine cm5mod(NAT,IZ,CHIR,Q,CCM5,DHIRX,DHIRY,DHIRZ, &
  & DCM5X,DCM5Y,DCM5Z)
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (MZ=118)
DIMENSION Q(3,*),IZ(*),CHIR(*),CCM5(*)
DIMENSION RAD(MZ),A0(MZ),D(MZ,MZ)

!
!     COVALENT RADII of all elements
!     based on "Atomic Radii of the Elements," M. Mantina, R. Valero, C. J. Cramer, and D. G. Truhlar,
!     in CRC Handbook of Chemistry and Physics, 91st Edition (2010-2011),
!     edited by W. M. Haynes (CRC Press, Boca Raton, FL, 2010), pages 9-49-9-50;
!     corrected Nov. 17, 2010 for the 92nd edition.
!
rad = (/ &
 & 0.32D0,0.37D0,1.30D0,0.99D0,0.84D0,0.75D0,0.71D0,0.64D0,0.60D0, &
 & 0.62D0,1.60D0,1.40D0,1.24D0,1.14D0,1.09D0,1.04D0,1.00D0,1.01D0, &
 & 2.00D0,1.74D0,1.59D0,1.48D0,1.44D0,1.30D0,1.29D0,1.24D0,1.18D0, &
 & 1.17D0,1.22D0,1.20D0,1.23D0,1.20D0,1.20D0,1.18D0,1.17D0,1.16D0, &
 & 2.15D0,1.90D0,1.76D0,1.64D0,1.56D0,1.46D0,1.38D0,1.36D0,1.34D0, &
 & 1.30D0,1.36D0,1.40D0,1.42D0,1.40D0,1.40D0,1.37D0,1.36D0,1.36D0, &
 & 2.38D0,2.06D0,1.94D0,1.84D0,1.90D0,1.88D0,1.86D0,1.85D0,1.83D0, &
 & 1.82D0,1.81D0,1.80D0,1.79D0,1.77D0,1.77D0,1.78D0,1.74D0,1.64D0, &
 & 1.58D0,1.50D0,1.41D0,1.36D0,1.32D0,1.30D0,1.30D0,1.32D0,1.44D0, &
 & 1.45D0,1.50D0,1.42D0,1.48D0,1.46D0,2.42D0,2.11D0,2.01D0,1.90D0, &
 & 1.84D0,1.83D0,1.80D0,1.80D0,1.73D0,1.68D0,1.68D0,1.68D0,1.65D0, &
 & 1.67D0,1.73D0,1.76D0,1.61D0,1.57D0,1.49D0,1.43D0,1.41D0,1.34D0, &
 & 1.29D0,1.28D0,1.21D0,1.22D0,1.36D0,1.43D0,1.62D0,1.75D0,1.65D0, &
 & 1.57D0 /)

!
!     CM5 MODEL PARAMETERS
!
DO I=1,MZ
   A0(I)=0.D0
   DO J=1,MZ
      D(I,J)=0.D0
   END DO
END DO

!
!     definition of atomwise parameters
!

a0= (/ &
 &  0.0056,-0.1543, 0.0000, 0.0333,-0.1030,-0.0446,-0.1072,-0.0802, &
 & -0.0629,-0.1088, 0.0184, 0.0000,-0.0726,-0.0790,-0.0756,-0.0565, &
 & -0.0444,-0.0767, 0.0130, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000,-0.0512,-0.0557, &
 & -0.0533,-0.0399,-0.0313,-0.0541, 0.0092, 0.0000, 0.0000, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 & -0.0361,-0.0393,-0.0376,-0.0281,-0.0220,-0.0381, 0.0065, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 & -0.0255,-0.0277,-0.0265,-0.0198,-0.0155,-0.0269, 0.0046, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 &  0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
 & -0.0179,-0.0195,-0.0187,-0.0140,-0.0110,-0.0189 /)

DO K1=1,MZ
   DO K2=K1+1,MZ
      D(K1,K2)=A0(K1)-A0(K2)
   END DO
END DO
!
!     PAIRWISE PARAMETERS
!
D( 1, 6)= 0.0502
D( 1, 7)= 0.1747
D( 1, 8)= 0.1671
D( 6, 7)= 0.0556
D( 6, 8)= 0.0234
D( 7, 8)=-0.0346

DO I=1,MZ
   DO J=I+1,MZ
      D(J,I)=-D(I,J)
   END DO
END DO
!     ALPHA
ALP=2.4740

!     C-COEFFICIENT: 0.7050   ! ALREADY INCLUDED IN A0

DO K=1,NAT
   CCM5(K)=CHIR(K)
   DO K1=1,NAT
      IF (IZ(K).NE.IZ(K1)) THEN
         DIS=DSQRT((Q(1,K)-Q(1,K1))**2+(Q(2,K)-Q(2,K1))**2+ &
           & (Q(3,K)-Q(3,K1))**2)
         BKK=DEXP(-ALP*(DIS-RAD(IZ(K))-RAD(IZ(K1))))
         CCM5(K)=CCM5(K)+BKK*D(IZ(K),IZ(K1))
      END IF
   END DO
END DO
DHIRX=0.D0
DHIRY=0.D0
DHIRZ=0.D0
DCM5X=0.D0
DCM5Y=0.D0
DCM5Z=0.D0
DO J=1,NAT
   DHIRX=DHIRX+Q(1,J)*CHIR(J)*4.803242D0
   DHIRY=DHIRY+Q(2,J)*CHIR(J)*4.803242D0
   DHIRZ=DHIRZ+Q(3,J)*CHIR(J)*4.803242D0
   DCM5X=DCM5X+Q(1,J)*CCM5(J)*4.803242D0
   DCM5Y=DCM5Y+Q(2,J)*CCM5(J)*4.803242D0
   DCM5Z=DCM5Z+Q(3,J)*CCM5(J)*4.803242D0
END DO

RETURN
end subroutine


C Copyright (c) 1980, InfoCom Computers and Communications, Cambridge MA 02142
C All rights reserved, commercial usage strictly prohibited.
C Written by R. M. Supnik.
C Revisions Copyright (c) 2021, Darth Spectra (Lydia Marie Williamson).
C
C Steal winner's valuables
	INTEGER FUNCTION ROBADV(ADV,NR,NC,NA)
	IMPLICIT INTEGER (A-Z)
	include 'objects.h'
	include 'oflags.h'
C
	ROBADV=0
C						!COUNT OBJECTS
	DO 100 I=1,OLNT
	  IF((OADV(I).NE.ADV).OR.(OTVAL(I).LE.0).OR.
     &	(IAND(OFLAG2(I),SCRDBT).NE.0)) GO TO 100
	  CALL NEWSTA(I,0,NR,NC,NA)
C						!STEAL OBJECT
	  ROBADV=ROBADV+1
100	CONTINUE
	RETURN
	END
C
C Steal room valuables
	INTEGER FUNCTION ROBRM(RM,PR,NR,NC,NA)
	IMPLICIT INTEGER (A-Z)
	LOGICAL PROB,QHERE
	include 'objects.h'
	include 'oflags.h'
C
	ROBRM=0
C						!COUNT OBJECTS
	DO 100 I=1,OLNT
C						!LOOP ON OBJECTS.
	  IF(.NOT. QHERE(I,RM)) GO TO 100
	  IF((OTVAL(I).LE.0).OR.(IAND(OFLAG2(I),SCRDBT).NE.0).OR.
     &	(IAND(OFLAG1(I),VISIBT).EQ.0).OR.(.NOT.PROB(PR,PR)))
     &	GO TO 50
	  CALL NEWSTA(I,0,NR,NC,NA)
	  ROBRM=ROBRM+1
	  OFLAG2(I)=IOR(OFLAG2(I),TCHBT)
	  GO TO 100
50	  IF(IAND(OFLAG2(I),ACTRBT).NE.0)
     &	ROBRM=ROBRM+ROBADV(OACTOR(I),NR,NC,NA)
100	CONTINUE
	RETURN
	END
C
C See if villain is winning
	LOGICAL FUNCTION WINNIN(VL,HR)
	IMPLICIT INTEGER (A-Z)
	LOGICAL PROB
	include 'objects.h'
C
	VS=OCAPAC(VL)
C						!VILLAIN STRENGTH
	PS=VS-FIGHTS(HR,.TRUE.)
C						!HIS MARGIN OVER HERO
	WINNIN=PROB(90,100)
	IF(PS.GT.3) RETURN
C						!+3... 90% WINNING
	WINNIN=PROB(75,85)
	IF(PS.GT.0) RETURN
C						!>0... 75% WINNING
	WINNIN=PROB(50,30)
	IF(PS.EQ.0) RETURN
C						!=0... 50% WINNING
	WINNIN=PROB(25,25)
	IF(VS.GT.1) RETURN
C						!ANY VILLAIN STRENGTH.
	WINNIN=PROB(10,0)
	RETURN
	END
C
C Compute fight strength
	INTEGER FUNCTION FIGHTS(H,FLG)
	IMPLICIT INTEGER (A-Z)
	LOGICAL FLG
C
C GAME STATE
C
	include 'state.h'
	include 'advers.h'
C
C Initialized data
	DATA SMAX/7/,SMIN/2/
C
	FIGHTS=SMIN+((((SMAX-SMIN)*ASCORE(H))+(MXSCOR/2))/MXSCOR)
	IF(FLG) FIGHTS=FIGHTS+ASTREN(H)
	RETURN
	END
C
C Compute villain strength
	INTEGER FUNCTION VILSTR(V)
	IMPLICIT INTEGER (A-Z)
	include 'parser.h'
	include 'objects.h'
	include 'oflags.h'
	include 'oindex.h'
	include 'villians.h'
	include 'flags.h'
C VILSTR, PAGE 2
C
	VILSTR=OCAPAC(V)
	IF(VILSTR.LE.0) RETURN
	IF((V.NE.THIEF).OR..NOT.THFENF) GO TO 100
	THFENF=.FALSE.
C						!THIEF UNENGROSSED.
	VILSTR=MIN0(VILSTR,2)
C						!NO BETTER THAN 2.
C
100	DO 200 I=1,VLNT
C						!SEE IF  BEST WEAPON.
	  IF((VILLNS(I).EQ.V).AND.(PRSI.EQ.VBEST(I)))
     &	VILSTR=MAX0(1,VILSTR-1)
200	CONTINUE
	RETURN
	END


subroutine upgm_driver(sr,start_jday,end_jday,plant_jday,harvest_jday,aepa,aifs,&
                     & antes,antss,blstrs,boots,browns,callgdd,canht,canopyflg, &
                     & cliname,cots,cropname,dayhtinc,dents,doughs,drs,dummy1,  &
                     & dummy2,ears,ecanht,egdd,emrgflg,ems,endlgs,epods,ergdd,  &
                     & eseeds,first7,fps,fullbs,gddtbg,germgdd,germs,ggdd,      &
                     & gmethod,gpds,growth_stress,halfbs,heads,hrs,icli,ies,    &
                     & ies2,infls,joints,lf12s,lf1s,lf2s,lf3s,lf4s,lf8s,mats,   &
                     & maxht,mffls,milks,mpods,mseeds,opens,pchron,pd,phenolflg,&
                     & pm,py,hd,hm,hy,seedsw,silks,soilwat,srs,tbase,tis,toptlo,&
                     & toptup,tsints,tss,tupper,wfpslo,wfpsup,yelows,seedbed,   &
                     & swtype,growcrop_flg,am0hrvfl,co2x,co2y,co2atmos)
!
implicit none
!
include 'p1werm.inc'
include 'precision.inc'
include 'command.inc'
include 'file.fi'
include 'w1clig.inc'
include 's1layr.inc'
include 's1dbc.inc'
include 's1dbh.inc'
include 's1phys.inc'
include 'd1glob.inc'
include 'c1gen.inc'
include 'm1flag.inc'
include 'm1sim.inc'
include 'm1dbug.inc'
include 'h1hydro.inc'
include 'h1temp.inc'
include 'c1info.inc'
include 'c1db1.inc'
include 'c1db2.inc'
include 'w1wind.inc'
include 'c1glob.inc'
include 'h1et.inc'
include 's1sgeo.inc'
include 'h1db1.inc'
include 's1agg.inc'
include 'prevstate.inc'
!
! Dummy arguments
!
real :: aepa,canht,dayhtinc,ecanht,gddtbg,maxht,pchron,tbase,toptlo,toptup,     &
      & tupper,co2atmos
integer :: am0hrvfl,canopyflg,emrgflg,end_jday,first7,gmethod,growth_stress,    &
         & harvest_jday,icli,pd,phenolflg,plant_jday,pm,py,hd,hm,hy,seedsw,sr,  &
         & start_jday
logical :: callgdd,growcrop_flg
character(80) :: cliname
character(80) :: cropname
character(40) :: seedbed,swtype
integer,dimension(4) :: aifs,antes,antss,blstrs,boots,browns,cots,dents,doughs, &
                      & drs,ears,ems,endlgs,epods,eseeds,fps,fullbs,germs,gpds, &
                      & halfbs,heads,hrs,ies,ies2,infls,joints,lf12s,lf1s,lf2s, &
                      & lf3s,lf4s,lf8s,mats,mffls,milks,mpods,mseeds,opens,     &
                      & silks,srs,tis,tsints,tss,yelows
character(5),dimension(30) :: dummy1
real,dimension(30) :: dummy2
real,dimension(6) :: egdd,ggdd
real,dimension(4) :: ergdd,germgdd,wfpslo,wfpsup
character(80),dimension(4) :: soilwat
real,dimension(10) :: co2x,co2y
!
! Local variables
!
integer :: chkid,chkim,chkiy,ed,em,ey,i,id,im,iy,julday,               &
         & mature_warn_flg,row,sd,sm,sy,co2dy,co2mn,co2yr
real :: elrate,germd,wlow,wup
!
! local variables
!
!real, save :: canht
!
! start of time loop - does this work correctly across multiple years and crops?
!
do am0jd = start_jday,end_jday   ! currently must start on 1/1 and end on 12/31
!

  call caldat(am0jd,id,im,iy)
!  if ((im.lt.4).and.(iy.eq.1)) then
!      print*, 'in main id = ', id,'im = ', im, 'iy = ', iy !, 'wwtdmx = ', wwtdmx(dayidx)
!  end if
!debe added check to determine if it is a leap year. if it is not leap year then continue.
! if it is leap year skip this day and go to 3/1/yr.
!  if ((id.eq.29).and.(im.eq.2)) then  !this didn't work
!   id = id + 1
!   im = im + 1
!   print * , 'in leap year id = ', id, 'im = ', im
!  end if
!

!  if ((id.ne.29).or.(im.ne.2)) then !check if leap year
    ! this reads in one day of climate data
  call climate_input(id,im,iy,icli)
!  if ((id.ne.29).or.(im.ne.2)) then !check if leap year
    !
    ! read in daily water stress
  read (upgmstress,*) chkid,chkim,chkiy,ahfwsf(1)     !upgm_stress.dat
  if ((chkid/=id).or.(chkim/=im).or.(chkiy/=iy)) then
     write (*,*) 'error in dates in water stress file - stop'
     call exit(1)
  end if

!read in daily atmospheric co2 values.
  !co2dy = day; co2mn = month; co2yr = year
  !co2atmos = atmospheric co2 value for the day.
  read (upgmco2atmos,*) co2dy, co2mn, co2yr, co2atmos  !upgm_co2atmos.dat

!  if ((id.ne.29).or.(im.ne.2)) then !check if leap year
    !
  if (am0jd==plant_jday) then
     write (*,*) 'planting date: ',pd,'/',pm,'/',py
     growcrop_flg = .true.
     am0cif = .true.
     am0cgf = .true.
  end if
!

    !  if (am0jd.eq.harvest_jday) then !original way

    ! debe added new method of determining when harvest day occurs utilizing the
    ! phenolflg and writing out the value in season.out
  if (((phenolflg==1).and.(hrs(1)/=999).and.am0hrvfl==0).or.                    &
    & ((phenolflg==0).and.(am0jd==harvest_jday))) then

     if (phenolflg==1) then
        write (*,*) 'harvest date: ',hrs(1),hrs(2),hrs(3),hrs(4)
     else if (phenolflg==0) then
        write (*,*) 'harvest date: ',hd,'/',hm,'/',hy
     end if
     am0cgf = .false.
     am0hrvfl = 1     ! debe uncommented this line because it is now needed to prevent crop_endseason
                      ! being called after harvest every day until the end date of simulation.
    !
     call crop_endseason(ac0nam(sr),am0cfl,nslay(sr),ac0idc(sr),acdayam(sr),    &
                       & acthum(sr),acxstmrep(sr),prevstandstem(sr),            &
                       & prevstandleaf(sr),prevstandstore(sr),prevflatstem(sr), &
                       & prevflatleaf(sr),prevflatstore(sr),prevbgstemz(1,sr),  &
                       & prevrootstorez(1,sr),prevrootfiberz(1,sr),prevht(sr),  &
                       & prevstm(sr),prevrtd(sr),prevdayap(sr),prevhucum(sr),   &
                       & prevrthucum(sr),prevgrainf(sr),prevchillucum(sr),      &
                       & prevliveleaf(sr),acdayspring(sr),mature_warn_flg,      &
                       & acycon,acynmu,ies,joints,boots,heads,antss,mats,hrs,   &
                       & phenolflg)
    !debe added acycon to the passing arguments to crop_endseason to allow calculation
    ! of the yield in crop_endseason.
    !debe added phenolflg and several growth stage arrays to be passed to crop_endseason
    ! to print out in season.out. as different crops are tested more growth stage variables
    ! appropriate to each crop may need to be passed to crop_endseason.
  end if
    !
  if (growcrop_flg.eqv..true.) then
    !debe added the following variables for the emerge subroutine to the call to
    ! the callcrop subroutine: seedsw, soilwat, wfpslo, wfpsup, germgdd, ergdd,
    ! cropname, ddap, dgdds, elong, gddday.
    !debe added the variables icli and pd, pm, py to the call to the callcrop
    ! subroutine to enable printing the weather file name and planting date
    ! in emerge.out.
    !
    !debe added tupper and callgdd for the gddcalc subroutine to the call to
    ! the callcrop subroutine. tupper is read in from upgm_crop.dat. callgdd is
    ! initialized in cropinit.
    !debe added canopyflg to callcrop.
    !
    ! (am0jd-plant_jday+1) = current day of crop growth
    ! debe added temperature variables: tbase, toptlo, topup, tupper, canopyflg
    ! debe added passing the new variable 'phenolflg' which is read in from upgm_crop.dat
    ! and the phenological growth stages variables to callcrop which will pass
    ! them on to crop.
     call callcrop(aepa,aifs,am0jd-plant_jday+1,1,antes,antss,blstrs,boots,     &
                 & browns,callgdd,canht,canopyflg,cliname,cots,cropname,        &
                 & dayhtinc,dents,doughs,drs,dummy1,dummy2,ears,ecanht,egdd,    &
                 & emrgflg,ems,endlgs,epods,ergdd,eseeds,first7,fps,fullbs,     &
                 & gddtbg,germgdd,germs,ggdd,gmethod,gpds,growth_stress,halfbs, &
                 & heads,hrs,icli,ies,ies2,infls,joints,lf12s,lf1s,lf2s,lf3s,   &
                 & lf4s,lf8s,mats,maxht,mffls,milks,mpods,mseeds,opens,pchron,  &
                 & pd,phenolflg,pm,py,seedsw,silks,soilwat,srs,tbase,tis,toptlo,&
                 & toptup,tsints,tss,tupper,wfpslo,wfpsup,yelows,co2x,co2y,     &
                 & co2atmos)

         !if (am0jd.eq.harvest_jday) growcrop_flg = .false.
         !de and gm changed the above code so that if the input harvest date is
         ! reached before hrs(1) has a value .ne. to 999 when using phenolflg = 1,
         ! simulation will continue until it does reach a harvest date.
     if (((phenolflg==1).and.(hrs(1)/=999)).or.                                 &
       & ((phenolflg==0).and.(am0jd==harvest_jday))) growcrop_flg = .false.

  end if
! end if !end leap year check
end do ! end do loop for current day
    ! debe print out canopy height and the canopyflg at the end of the run
write (luophenol,1000) canht,canopyflg
    !
 1000 format ('canopy height =',2x,f5.1,'(cm) ','canopyflg = ',2x,i1)

end subroutine upgm_driver


c     Response function factor = 0.96992
      subroutine avhrr34(z0, p0, t0, u0, ux, nlev,
     *co2, n2o, f11, f12, ch4,
     *od, wght, ntau)
      INCLUDE "avhrr.inc"
      real co2, n2o, ch4, f11, f12
      real z0(mm)
      real od(4,mm)
      real wght(4)
      integer ntau,nlev
      real wi(8),xi(8),p0(mq),p(mm),t0(mq),t(mm),bnu(mm),u0(mq),u(mm),
     *uch4(mm),tau(6,mm),tauch4(6,mm),tauf(6,6,mm),x(mm,8),y(mm,8),
     *sx(6,6,mm),sy(6,6,mm),f(6),fch4(6),fac(mm),tsx(mq),tsy(mq)
      data xi /.01986,.10167,.23723,.40828,
     *         .59172,.76277,.89833,.98014/
      data wi /.05062,.11119,.15685,.18134,
     *         .18134,.15685,.11119,.05062/
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c0      omega=2660.5
c0      delw=360.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c1      omega=2525.0
c1      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c2      omega=2595.0
c2      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c3      omega=2667.5
c3      delw=75.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
      omega=2740.0
      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c5      omega=2817.5
c5      delw=85.0
      omegas=omega
      sigma=5.67e-05
      sconst=1.368e+06
      tsun=5710.0
      fsun=sigma*tsun**4
      mlv=nlyr
      do 5 m=1,nlyr
        t(m)=(t0(m)+t0(m+1))/2.0
        p(m)=(p0(m)+p0(m+1))/2.0
        call flux_34(bnu(m),omega,t(m))
        fac(m)=z0(m+1)-z0(m)
c       u(m)=fac(m)*(u0(m)+u0(m+1))/2.0*6.023e+23/2.687e+19/18.01534
        u(m)=fac(m)*(u0(m)+u0(m+1))/2.0
        uch4(m)=p(m)*1.01325e+06/(1.3805e-16*t(m))*ch4*1e-6*fac(m)*
     *       1.0e+05/6.023e+23*16.04303
 5    continue
      do 7 m=1,nlev
        tsx(m)=0.0
        tsy(m)=0.0
 7    continue
      call flux_34(back,omega,t0(1))
      call flux_34(bsun,omegas,tsun)
      bsun=bsun/fsun*sconst
      call ck_34(ni,mlv,u,delw,f,p,t,tau)
      call ckch4_34(nch4,mlv,uch4,delw,fch4,p,t,tauch4)
      do 10 m=1,nlyr
        do i=1,ni
          do ia=1,nch4
            tauf(i,ia,m)=tau(i,m)+tauch4(ia,m)
c           tauf(i,ia,m)=tauch4(ia,m)
c           tauf(i,ia,m)=tau(i,m)
          end do
        end do
 10   continue
      do 90 i=1,ni
       do 85 ia=1,nch4
        do 30 m=nlyr,1,-1
          do 20 j=1,8
           if(m.eq.nlyr)then
c           y(m,j)=bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
            y(m,j)=bsun*0.6*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           else
            y(m,j)=y(m+1,j)*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           end if
 20       continue
 30     continue
        do 50 m=1,nlyr
          sx(i,ia,m)=0.0
          sy(i,ia,m)=0.0
          do 40 j=1,8
           if(m.eq.1)then
c            x(m,j)=back*exp(-tauf(i,ia,m)/xi(j))+
c     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
            x(m,j)=(0.10*y(m,j)+0.90*back)*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           else
            x(m,j)=x(m-1,j)*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           end if
 40       continue
 50     continue
        do 70 m=1,nlyr
          do 60 j=1,8
            sx(i,ia,m)=sx(i,ia,m)+2.0*x(m,j)*wi(j)*xi(j)
            sy(i,ia,m)=sy(i,ia,m)+2.0*y(m,j)*wi(j)*xi(j)
 60       continue
 70     continue
        do 80 m=1,nlyr
           tsx(m+1)=tsx(m+1)+sx(i,ia,m)*delw*f(i)*fch4(ia)
           tsy(m)=tsy(m)+sy(i,ia,m)*delw*f(i)*fch4(ia)
 80     continue
        tb=tb+back*delw*f(i)*fch4(ia)
        tsx(1)=tb
 85    continue
 90   continue
      tb=0.10*tsy(1)+0.90*tb
      tsx(1)=tb
      tsy(nlev)=tsy(nlev)+bsun*0.60*delw
      do 95 m=1,nlev
cbm         write(6,100)m-1,tsx(m),tb-tsx(m),tsy(m)
 95   continue
      do i1=1,2
       do i2=1,2
        do m=1,nlyr
         od(1+(i2-1)+(i1-1)*2,m) =
     *tauf(i1,i2,m)
         wght(1+(i2-1)+(i1-1)*2) =
     *f(i1) * fch4(i2)
        enddo
       enddo
      enddo
      ntau=4
 100  format(i3,3f15.7)
      end
c *********************************************************************
      subroutine flux_34(bnu,omega,t)
      INCLUDE "avhrr.inc"
      bnu=0.0
      z=3.14159
      bnu=z/1000.0*((2.*6.625e-27)*(2.997925e+10)**2
     *    *omega**3)/(exp(min(88.0,1.4388*omega/t))-1.0)
      return
      end
c *********************************************************************
      subroutine ck_34(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=2
      f(1)=0.691347
      f(2)=0.308653
      k(1)=0.00811417
      do i=2,ni
        k(i)=32.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0170,0.0170,0.0170,0.0170,0.0170,0.0170,0.0170,0.0170,0.0170,
     *0.0394,0.0745,0.1271,0.2055,0.3246,0.4997,0.7453,0.9174,1.3687,
     *1.9269,
     *-2.475e-05,-2.475e-05,-2.475e-05,-2.475e-05,-2.475e-05,-2.475e-05,
     *-2.475e-05,-2.475e-05,-2.475e-05,-7.000e-05,-1.256e-04,-2.133e-04,
     *-3.581e-04,-5.873e-04,-9.344e-04,-1.429e-03,-1.971e-03,-3.163e-03,
     *-4.805e-03,
     *-5.000e-08,-5.000e-08,-5.000e-08,-5.000e-08,-5.000e-08,-5.000e-08,
     *-5.000e-08,-5.000e-08,-5.000e-08,1.437e-07,2.094e-07,4.875e-07,
     *1.266e-06,2.250e-06,3.816e-06,6.334e-06,9.337e-06,1.355e-05,
     *1.713e-05/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.3572,1.3572,1.3572,1.3572,1.3572,1.3572,1.3572,1.3572,1.3572,
     *1.3559,1.3534,1.3501,1.3430,1.3351,1.3223,1.3054,1.0989,1.1449,
     *1.1612,
     *-2.319e-03,-2.319e-03,-2.319e-03,-2.319e-03,-2.319e-03,-2.319e-03,
     *-2.319e-03,-2.319e-03,-2.319e-03,-2.317e-03,-2.314e-03,-2.297e-03,
     *-2.277e-03,-2.263e-03,-2.233e-03,-2.201e-03,-1.948e-03,-2.008e-03,
     *-1.985e-03,
     *8.625e-06,8.625e-06,8.625e-06,8.625e-06,8.625e-06,8.625e-06,
     *8.625e-06,8.625e-06,8.625e-06,8.834e-06,9.031e-06,9.009e-06,
     *9.244e-06,9.244e-06,9.078e-06,8.884e-06,7.831e-06,8.041e-06,
     *8.213e-06/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end
c**********************************************************************
      subroutine ckch4_34(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=2
      f(1)=0.955213
      f(2)=0.044787
      k(1)=12.423432
      do i=2,ni
        k(i)=36.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.1859,0.1859,0.1859,0.1859,0.1859,0.1859,0.1859,0.1859,0.1859,
     *0.2208,0.2683,0.3318,0.4140,0.5154,0.6371,0.7750,0.9198,1.0940,
     *1.2865,
     *1.211e-03,1.211e-03,1.211e-03,1.211e-03,1.211e-03,1.211e-03,
     *1.211e-03,1.211e-03,1.211e-03,1.193e-03,1.184e-03,1.191e-03,
     *1.205e-03,1.226e-03,1.184e-03,1.157e-03,1.009e-03,7.993e-04,
     *6.330e-04,
     *2.197e-06,2.197e-06,2.197e-06,2.197e-06,2.197e-06,2.197e-06,
     *2.197e-06,2.197e-06,2.197e-06,1.691e-06,1.406e-06,1.006e-06,
     *2.469e-07,1.844e-07,-2.625e-07,-8.656e-07,-8.156e-07,-1.113e-06,
     *-3.144e-06/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.4918,1.4918,1.4918,1.4918,1.4918,1.4918,1.4918,1.4918,1.4918,
     *1.4718,1.4439,1.4072,1.3594,1.2984,1.2273,1.1456,1.0490,0.9508,
     *0.8346,
     *4.899e-04,4.899e-04,4.899e-04,4.899e-04,4.899e-04,4.899e-04,
     *4.899e-04,4.899e-04,4.899e-04,4.851e-04,4.761e-04,4.797e-04,
     *4.957e-04,4.994e-04,4.963e-04,5.163e-04,5.585e-04,7.344e-04,
     *8.940e-04,
     *-1.103e-05,-1.103e-05,-1.103e-05,-1.103e-05,-1.103e-05,-1.103e-05,
     *-1.103e-05,-1.103e-05,-1.103e-05,-1.131e-05,-1.069e-05,-1.058e-05,
     *-1.050e-05,-1.032e-05,-1.135e-05,-1.063e-05,-1.075e-05,-1.026e-05,
     *-8.906e-06/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end