      SUBROUTINE DT_RESNCL(Epn,Nloop,Mode)

      INCLUDE '(DBLPRC)'
      SAVE

      DOUBLE PRECISION aip , aipz , ait , aitz , amsec , AMUAMU ,
     &                 chklev , dum , dum1 , dum2 , ebipot , Epn ,
     &                 epni , EXMSAZ , FM2MM , ONE , pei , pfsp , pm1 ,
     &                 pm2
      DOUBLE PRECISION pmass1 , pmass2 , pmomb , pmomm , psec , psec0 ,
     &                 psecn , pseco , pzi , RNUCLE , scpot , THREE ,
     &                 thresh , TINY1 , TINY10 , TINY2 , TINY3 , TINY4 ,
     &                 TWO , ZERO
      INTEGER i , icor , idsec , idum , idxb , idxcor , idxm , idxoth ,
     &        iflg , imode , iother , ipot , irej1 , izdum , j , jpcw ,
     &        jpmod , jpw , jtcw , jtw
      INTEGER k , MAXNCL , MAXINT , MAXSQU , MAXVQU , Mode , ncor ,
     &        Nloop , nob , nom

C***********************************************************************
C Treatment of residual nuclei and nuclear effects.                    *
C         MODE = 1     initializations                                 *
C              = 2     treatment of final state                        *
C This version dated 16.11.95 is written by S. Roesler.                *
C***********************************************************************

C
      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
     &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10)
      PARAMETER (AMUAMU=AMUGEV,FM2MM=1.0D-12,RNUCLE=1.12D0)

      PARAMETER (MAXNCL=260,MAXVQU=MAXNCL,MAXSQU=20*MAXVQU,
     &           MAXINT=MAXVQU+MAXSQU)

C event history
      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'
C particle properties (BAMJET index convention)
      INCLUDE 'inc/dtpart'
C flags for input different options
      INCLUDE 'inc/dtflg1'
C nuclear potential
      INCLUDE 'inc/dtnpot'
C properties of interacting particles
      INCLUDE 'inc/dtprta'
C properties of photon/lepton projectiles
      INCLUDE 'inc/dtgpro'
C Lorentz-parameters of the current interaction
      INCLUDE 'inc/dtltra'
C treatment of residual nuclei: wounded nucleons
      INCLUDE 'inc/dtwoun'
C treatment of residual nuclei: 4-momenta
      INCLUDE 'inc/dtrnu1'

      DIMENSION pfsp(4) , psec(4) , psec0(4)
      DIMENSION pmomb(5000) , idxb(5000) , pmomm(10000) , idxm(10000) ,
     &          idxcor(15000) , idxoth(NMXHKK)

      IF ( Mode.EQ.2 ) THEN

C------- treatment of final state

         Nloop = Nloop + 1
         IF ( Nloop.GT.1 ) scpot = 0.10D0

         jpw = NPW
         jpcw = NPCw
         jtw = NTW
         jtcw = NTCw
         DO k = 1 , 4
            pfsp(k) = ZERO
         END DO

         nob = 0
         nom = 0
         DO i = NPOint(4) , NHKk
            idxoth(i) = -1
            IF ( ISThkk(i).EQ.1 ) THEN
               IF ( IDBam(i).NE.7 ) THEN
                  ipot = 0
                  iother = 0
C particle moving into forward direction
                  IF ( PHKk(3,i).GE.ZERO ) THEN
C   most likely to be effected by projectile potential
                     ipot = 1
C     there is no projectile nucleus, try target
                     IF ( (IP.LE.1) .OR. ((IP-NPW).LE.1) ) THEN
                        ipot = 2
                        IF ( IP.GT.1 ) iother = 1
C       there is no target nucleus --> skip
                        IF ( (IT.LE.1) .OR. ((IT-NTW).LE.1) ) GOTO 50
                     END IF
C particle moving into backward direction
                  ELSE
C   most likely to be effected by target potential
                     ipot = 2
C     there is no target nucleus, try projectile
                     IF ( (IT.LE.1) .OR. ((IT-NTW).LE.1) ) THEN
                        ipot = 1
                        IF ( IT.GT.1 ) iother = 1
C       there is no projectile nucleus --> skip
                        IF ( (IP.LE.1) .OR. ((IP-NPW).LE.1) ) GOTO 50
                     END IF
                  END IF
                  iflg = -ipot
C nobam=3: particle is in overlap-region or neither inside proj. nor target
C      =1: particle is not in overlap-region AND is inside target (2)
C      =2: particle is not in overlap-region AND is inside projectile (1)
C flag particles which are inside the nucleus ipot but not in its
C overlap region
                  IF ( (NOBam(i).NE.ipot) .AND. (NOBam(i).LT.3) )
     &                 iflg = ipot
                  IF ( IDBam(i).EQ.0 ) THEN
C baryons: keep all nucleons and all others where flag is set
                  ELSE IF ( IIBar(IDBam(i)).NE.0 ) THEN
                     IF ( (IDBam(i).EQ.1) .OR. (IDBam(i).EQ.8) .OR.
     &                    (iflg.GT.0) ) THEN
                        nob = nob + 1
                        pmomb(nob) = PHKk(3,i)
                        idxb(nob)
     &                     = SIGN(10000000*IABS(iflg)+1000000*iother+i,
     &                     iflg)
                     END IF
C mesons: keep only those mesons where flag is set
                  ELSE IF ( iflg.GT.0 ) THEN
                     nom = nom + 1
                     pmomm(nom) = PHKk(3,i)
                     idxm(nom) = 10000000*iflg + 1000000*iother + i
                  END IF
               END IF
            END IF
 50      END DO
C
C sort particles in the arrays according to increasing long. momentum
         CALL DT_SORT1(pmomb,idxb,nob,1,nob,1)
         CALL DT_SORT1(pmomm,idxm,nom,1,nom,1)
C
C shuffle indices into one and the same array according to the later
C sequence of correction
         ncor = 0
         IF ( IT.GT.1 ) THEN
            DO i = 1 , nob
               IF ( pmomb(i).GT.ZERO ) GOTO 60
               ncor = ncor + 1
               idxcor(ncor) = idxb(i)
            END DO
 60         IF ( IP.GT.1 ) THEN
               DO j = 1 , nob
                  i = nob + 1 - j
                  IF ( pmomb(i).LT.ZERO ) GOTO 100
                  ncor = ncor + 1
                  idxcor(ncor) = idxb(i)
               END DO
            ELSE
               DO i = 1 , nob
                  IF ( pmomb(i).GT.ZERO ) THEN
                     ncor = ncor + 1
                     idxcor(ncor) = idxb(i)
                  END IF
               END DO
            END IF
         ELSE
            DO j = 1 , nob
               i = nob + 1 - j
               ncor = ncor + 1
               idxcor(ncor) = idxb(i)
            END DO
         END IF
 100     DO i = 1 , nom
            IF ( pmomm(i).GT.ZERO ) GOTO 150
            ncor = ncor + 1
            idxcor(ncor) = idxm(i)
         END DO
 150     DO j = 1 , nom
            i = nom + 1 - j
            IF ( pmomm(i).LT.ZERO ) GOTO 200
            ncor = ncor + 1
            idxcor(ncor) = idxm(i)
         END DO
C
C      IF (NEVHKK.EQ.484) THEN
C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
C         WRITE(LOUT,9001) NOB,NOM,NCOR
C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
C         WRITE(LOUT,'(/,A)') ' baryons '
C         DO 950 I=1,NOB
CC           J     = IABS(IDXB(I))
CC           INDEX = J-IABS(J/10000000)*10000000
C            IPOT   = IABS(IDXB(I))/10000000
C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
C  950    CONTINUE
C         WRITE(LOUT,'(/,A)') ' mesons '
C         DO 951 I=1,NOM
CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
C            IPOT   = IABS(IDXM(I))/10000000
C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
C  951    CONTINUE
C 9002    FORMAT(1X,4I14,E14.5)
C         WRITE(LOUT,'(/,A)') ' all '
C         DO 952 I=1,NCOR
CC           J     = IABS(IDXCOR(I))
CC           INDEX = J-IABS(J/10000000)*10000000
CC            IPOT   = IABS(IDXCOR(I))/10000000
C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
C  952    CONTINUE
C 9003    FORMAT(1X,4I14)
C      ENDIF
C
 200     DO icor = 1 , ncor
            ipot = IABS(idxcor(icor))/10000000
            iother = IABS(idxcor(icor))/1000000 - ipot*10
            i = IABS(idxcor(icor)) - ipot*10000000 - iother*1000000
            idxoth(i) = 1

            idsec = IDBam(i)

C reduction of particle momentum by corresponding nuclear potential
C (this applies only if Fermi-momenta are requested)

            IF ( LFErmi ) THEN

C   Lorentz-transformation into the rest system of the selected nucleus
               imode = -ipot - 1
               CALL DT_LTRANS(PHKk(1,i),PHKk(2,i),PHKk(3,i),PHKk(4,i),
     &                        psec(1),psec(2),psec(3),psec(4),idsec,
     &                        imode)
               pseco = SQRT(psec(1)**2+psec(2)**2+psec(3)**2)
               amsec = SQRT(ABS((psec(4)-pseco)*(psec(4)+pseco)))
               jpmod = 0

               chklev = TINY3
               IF ( (EPRoj.GE.1.0D4) .AND. (idsec.EQ.7) ) chklev = TINY1
               IF ( EPRoj.GE.2.0D6 ) chklev = 1.0D0
               IF ( ABS(amsec-AAM(idsec)).GT.chklev ) THEN

                  IF ( IOUlev(3).GT.0 .AND. LPRi.GT.4 )
     &                 WRITE (LOUt,99010) i , NEVhkk , idsec , amsec ,
     &                 AAM(idsec)
99010             FORMAT (1X,'RESNCL: inconsistent mass of particle',
     &                    ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
     &                    I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,
     &                    /)
                  GOTO 220
               END IF

               DO k = 1 , 4
                  psec0(k) = psec(k)
               END DO

C   the correction for nuclear potential effects is applied to as many
C   p/n as many nucleons were wounded; the momenta of other final state
C   particles are corrected only if they materialize inside the corresp.
C   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
C   = 3 part. outside proj. and targ., >=10 in overlapping region)
               IF ( (idsec.EQ.1) .OR. (idsec.EQ.8) ) THEN
                  IF ( ipot.EQ.1 ) THEN
                     IF ( (jpw.GT.0) .AND. (iother.EQ.0) ) THEN
C      this is most likely a wounded nucleon
C*test
C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
C*
                        psec(4) = psec(4) - scpot*EPOt(ipot,idsec)
                        jpw = jpw - 1
                        jpmod = 1
C      correct only if part. was materialized inside nucleus
C      and if it is ouside the overlapping region
                     ELSE IF ( (NOBam(i).NE.1) .AND. (NOBam(i).LT.3) )
     &                  THEN
                        psec(4) = psec(4) - scpot*EPOt(ipot,idsec)
                        jpmod = 1
                     END IF
                  ELSE IF ( ipot.EQ.2 ) THEN
                     IF ( (jtw.GT.0) .AND. (iother.EQ.0) ) THEN
C      this is most likely a wounded nucleon
C*test
C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
C*
                        psec(4) = psec(4) - scpot*EPOt(ipot,idsec)
                        jtw = jtw - 1
                        jpmod = 1
C      correct only if part. was materialized inside nucleus
                     ELSE IF ( (NOBam(i).NE.2) .AND. (NOBam(i).LT.3) )
     &                  THEN
                        psec(4) = psec(4) - scpot*EPOt(ipot,idsec)
                        jpmod = 1
                     END IF
                  END IF
               ELSE IF ( (NOBam(i).NE.ipot) .AND. (NOBam(i).LT.3) ) THEN
                  psec(4) = psec(4) - scpot*EPOt(ipot,idsec)
                  jpmod = 1
               END IF

               IF ( Nloop.EQ.1 ) THEN
C Coulomb energy correction:
C the treatment of Coulomb potential correction is similar to the
C one for nuclear potential
                  IF ( idsec.EQ.1 ) THEN
                     IF ( (ipot.EQ.1) .AND. (jpcw.GT.0) ) THEN
                        jpcw = jpcw - 1
                     ELSE IF ( (ipot.EQ.2) .AND. (jtcw.GT.0) ) THEN
                        jtcw = jtcw - 1
                     ELSE IF ( (NOBam(i).EQ.ipot) .OR. (NOBam(i).EQ.3) )
     &                  THEN
                        GOTO 210
                     END IF
                  ELSE IF ( (NOBam(i).EQ.ipot) .OR. (NOBam(i).EQ.3) )
     &                      THEN
                     GOTO 210
                  END IF
                  IF ( IICh(idsec).EQ.1 ) THEN
C    pos. particles: check if they are able to escape Coulomb potential
                     IF ( psec(4).LT.amsec+ETAcou(ipot) ) THEN
                        ISThkk(i) = 14 + ipot
                        IF ( ISThkk(i).EQ.15 ) THEN
                           DO k = 1 , 4
                              PHKk(k,i) = psec0(k)
                              TRClpr(k) = TRClpr(k) + psec0(k)
                           END DO
                           IF ( (idsec.EQ.1) .OR. (idsec.EQ.8) )
     &                        NPW = NPW - 1
                           IF ( idsec.EQ.1 ) NPCw = NPCw - 1
                        ELSE IF ( ISThkk(i).EQ.16 ) THEN
                           DO k = 1 , 4
                              PHKk(k,i) = psec0(k)
                              TRClta(k) = TRClta(k) + psec0(k)
                           END DO
                           IF ( (idsec.EQ.1) .OR. (idsec.EQ.8) )
     &                        NTW = NTW - 1
                           IF ( idsec.EQ.1 ) NTCw = NTCw - 1
                        END IF
                        GOTO 250
                     END IF
                  ELSE IF ( IICh(idsec).EQ.-1 ) THEN
C    neg. particles: decrease energy by Coulomb-potential
                     psec(4) = psec(4) - ETAcou(ipot)
                     jpmod = 1
                  END IF
               END IF

 210           IF ( psec(4).LT.amsec ) THEN

                  IF ( IOUlev(6).GT.0 .AND. LPRi.GT.4 )
     &                 WRITE (LOUt,99020) i , idsec , psec(4) , amsec
99020             FORMAT (1X,'KKINC: particle at DTEVT1-pos. ',I5,
     &                    ' is not allowed to escape nucleus',/,8X,
     &                    'id : ',I3,'   reduced energy: ',E15.4,
     &                    '   mass: ',E12.3)
                  ISThkk(i) = 14 + ipot
                  IF ( ISThkk(i).EQ.15 ) THEN
                     DO k = 1 , 4
                        PHKk(k,i) = psec0(k)
                        TRClpr(k) = TRClpr(k) + psec0(k)
                     END DO
                     IF ( (idsec.EQ.1) .OR. (idsec.EQ.8) ) NPW = NPW - 1
                     IF ( idsec.EQ.1 ) NPCw = NPCw - 1
                  ELSE IF ( ISThkk(i).EQ.16 ) THEN
                     DO k = 1 , 4
                        PHKk(k,i) = psec0(k)
                        TRClta(k) = TRClta(k) + psec0(k)
                     END DO
                     IF ( (idsec.EQ.1) .OR. (idsec.EQ.8) ) NTW = NTW - 1
                     IF ( idsec.EQ.1 ) NTCw = NTCw - 1
                  END IF
                  GOTO 250
               END IF

               IF ( jpmod.EQ.1 ) THEN
                  psecn = SQRT((psec(4)-amsec)*(psec(4)+amsec))
C 4-momentum after correction for nuclear potential
                  DO k = 1 , 3
                     psec(k) = psec(k)*psecn/pseco
                  END DO

C store recoil momentum from particles escaping the nuclear potentials
                  DO k = 1 , 4
                     IF ( ipot.EQ.1 ) THEN
                        TRClpr(k) = TRClpr(k) + psec0(k) - psec(k)
                     ELSE IF ( ipot.EQ.2 ) THEN
                        TRClta(k) = TRClta(k) + psec0(k) - psec(k)
                     END IF
                  END DO

C transform momentum back into n-n cms
                  imode = ipot + 1
                  CALL DT_LTRANS(psec(1),psec(2),psec(3),psec(4),
     &               PHKk(1,i),PHKk(2,i),PHKk(3,i),PHKk(4,i),idsec,
     &               imode)
               END IF

            END IF

 220        DO k = 1 , 4
               pfsp(k) = pfsp(k) + PHKk(k,i)
            END DO

 250     END DO

         DO i = NPOint(4) , NHKk
            IF ( (ISThkk(i).EQ.1) .AND. (idxoth(i).LT.0) ) THEN
               pfsp(1) = pfsp(1) + PHKk(1,i)
               pfsp(2) = pfsp(2) + PHKk(2,i)
               pfsp(3) = pfsp(3) + PHKk(3,i)
               pfsp(4) = pfsp(4) + PHKk(4,i)
            END IF
         END DO

         DO k = 1 , 5
            PRClpr(k) = TRClpr(k)
            PRClta(k) = TRClta(k)
         END DO

         IF ( (IP.EQ.1) .AND. (IT.GT.1) .AND. LFErmi ) THEN
C hadron-nucleus interactions: get residual momentum from energy-
C momentum conservation
            DO k = 1 , 4
               PRClpr(k) = ZERO
               PRClta(k) = PINipr(k) + PINita(k) - pfsp(k)
            END DO
         ELSE
C nucleus-hadron, nucleus-nucleus: get residual momentum from
C accumulated recoil momenta of particles leaving the spectators
C   transform accumulated recoil momenta of residual nuclei into
C   n-n cms
            pzi = PRClpr(3)
            pei = PRClpr(4)
            CALL DT_LTNUC(pzi,pei,PRClpr(3),PRClpr(4),2)
            pzi = PRClta(3)
            pei = PRClta(4)
            CALL DT_LTNUC(pzi,pei,PRClta(3),PRClta(4),3)
C        IF (IP.GT.1) THEN
            PRClpr(3) = PRClpr(3) + PINipr(3)
            PRClpr(4) = PRClpr(4) + PINipr(4)
C        ENDIF
            IF ( IT.GT.1 ) THEN
               PRClta(3) = PRClta(3) + PINita(3)
               PRClta(4) = PRClta(4) + PINita(4)
            END IF
         END IF

C check momenta of residual nuclei
         IF ( LEMcck ) THEN
            CALL DT_EVTEMC(-PINipr(1),-PINipr(2),-PINipr(3),-PINipr(4),
     &                     1,idum,idum)
            CALL DT_EVTEMC(-PINita(1),-PINita(2),-PINita(3),-PINita(4),
     &                     2,idum,idum)
            CALL DT_EVTEMC(PRClpr(1),PRClpr(2),PRClpr(3),PRClpr(4),2,
     &                     idum,idum)
            CALL DT_EVTEMC(PRClta(1),PRClta(2),PRClta(3),PRClta(4),2,
     &                     idum,idum)
            CALL DT_EVTEMC(pfsp(1),pfsp(2),pfsp(3),pfsp(4),2,idum,idum)
C*sr 19.12. changed to avoid output when used with phojet
C        CHKLEV = TINY3
            chklev = TINY1
            CALL DT_EVTEMC(dum,dum,dum,chklev,-1,501,irej1)
C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
C    &      CALL DT_EVTOUT(4)
            IF ( irej1.GT.0 ) RETURN
         END IF
         GOTO 99999
      END IF

C------- initializations

C initialize arrays for residual nuclei
      DO k = 1 , 5
         IF ( k.LE.4 ) pfsp(k) = ZERO
         PINipr(k) = ZERO
         PINita(k) = ZERO
         PRClpr(k) = ZERO
         PRClta(k) = ZERO
         TRClpr(k) = ZERO
         TRClta(k) = ZERO
      END DO
      scpot = ONE
      Nloop = 0

C correction of projectile 4-momentum for effective target pot.
C and Coulomb-energy (in case of hadron-nucleus interaction only)
      IF ( (IP.EQ.1) .AND. (IT.GT.1) .AND. LFErmi ) THEN
         epni = Epn
C   Coulomb-energy:
C     positively charged hadron - check energy for Coloumb pot.
         IF ( IICh(IJProj).EQ.1 ) THEN
            thresh = ETAcou(2) + AAM(IJProj)
            IF ( epni.LE.thresh ) THEN

               IF ( LPRi.GT.4 ) WRITE (LOUt,99030)
99030          FORMAT (/,1X,'KKINC:  WARNING!  projectile energy',
     &                 ' below Coulomb threshold - event rejected',/)
               ISThkk(1) = 1
               RETURN
            END IF
C     negatively charged hadron - increase energy by Coulomb energy
         ELSE IF ( IICh(IJProj).EQ.-1 ) THEN
            epni = epni + ETAcou(2)
         END IF
         IF ( (IJProj.EQ.1) .OR. (IJProj.EQ.8) ) THEN
C   Effective target potential
Csr 6.6. binding energy only (to avoid negative exc. energies)
C           EPNI = EPNI+EPOT(2,IJPROJ)
            ebipot = EBIndp(2)
            IF ( (IJProj.NE.1) .AND. (ABS(EPOt(2,IJProj)).GT.5.0D-3) )
     &           ebipot = EBIndn(2)
            epni = epni + ABS(ebipot)
C re-initialization of DTLTRA
            dum1 = ZERO
            dum2 = ZERO
            CALL DT_LTINI(IJProj,IJTarg,epni,dum1,dum2,0)
         END IF
      END IF

C projectile in n-n cms
      IF ( (IP.LE.1) .AND. (IT.GT.1) ) THEN
         pmass1 = AAM(IJProj)
C* VDM assumption
C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
         IF ( IJProj.EQ.7 ) pmass1 = AAM(IJProj) - SQRT(VIRt)
         pmass2 = AAM(1)
         pm1 = SIGN(pmass1**2,pmass1)
         pm2 = SIGN(pmass2**2,pmass2)
         PINipr(4) = (UMO**2-pm2+pm1)/(TWO*UMO)
         PINipr(5) = pmass1
         IF ( pmass1.GT.ZERO ) THEN
            PINipr(3) = SQRT((PINipr(4)-PINipr(5))*(PINipr(4)+PINipr(5))
     &                  )
         ELSE
            PINipr(3) = SQRT(PINipr(4)**2-pm1)
         END IF
         ait = DBLE(IT)
         aitz = DBLE(ITZ)

C  A.F.
C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
         PINita(5) = ait*AMUC12 + EMVGEV*EXMSAZ(ait,aitz,.TRUE.,izdum)

         CALL DT_LTNUC(ZERO,PINita(5),PINita(3),PINita(4),3)
      ELSE IF ( (IP.GT.1) .AND. (IT.LE.1) ) THEN
         pmass1 = AAM(1)
         pmass2 = AAM(IJTarg)
         pm1 = SIGN(pmass1**2,pmass1)
         pm2 = SIGN(pmass2**2,pmass2)
         PINita(4) = (UMO**2-pm1+pm2)/(TWO*UMO)
         PINita(5) = pmass2
         PINita(3) = -SQRT((PINita(4)-PINita(5))*(PINita(4)+PINita(5)))
         aip = DBLE(IP)
         aipz = DBLE(IPZ)
C  A.F.
C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
         PINipr(5) = aip*AMUC12 + EMVGEV*EXMSAZ(aip,aipz,.TRUE.,izdum)

         CALL DT_LTNUC(ZERO,PINipr(5),PINipr(3),PINipr(4),2)
      ELSE IF ( (IP.GT.1) .AND. (IT.GT.1) ) THEN
         aip = DBLE(IP)
         aipz = DBLE(IPZ)
C  A.F.
C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
         PINipr(5) = aip*AMUC12 + EMVGEV*EXMSAZ(aip,aipz,.TRUE.,izdum)

         CALL DT_LTNUC(ZERO,PINipr(5),PINipr(3),PINipr(4),2)
         ait = DBLE(IT)
         aitz = DBLE(ITZ)

C  A.F.
C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
         PINita(5) = ait*AMUC12 + EMVGEV*EXMSAZ(ait,aitz,.TRUE.,izdum)

         CALL DT_LTNUC(ZERO,PINita(5),PINita(3),PINita(4),3)
      END IF

C
C     Pinipr,Pinita projectile/target 4-momenta in the n-n cms system
C

99999 END SUBROUTINE


      SUBROUTINE PHO_STRFRA(Irej)
C********************************************************************
C
C     do all fragmentation of strings
C
C     output:  IREJ    0   successful
C                      1   rejection
C                     50   rejection due to user cutoffs
C
C********************************************************************

      IMPLICIT NONE
      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'
C  some constants
      INCLUDE 'inc/pocons'
C  event debugging information
      INCLUDE 'inc/podebg'
C  general process information
      INCLUDE 'inc/poprcs'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C  hard scattering data
      INCLUDE 'inc/pohslt'
C  standard particle data interface
      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

C  color string configurations including collapsed strings and hadrons
      INCLUDE 'inc/postrg'

      INTEGER Irej

      DOUBLE PRECISION px , py , pz , he , xmb , pt1 , pt2

      INTEGER i , ii , ij , ifound , ip , ip_old , ipmoth , ipos ,
     &        ibam , ijoin , igen , is , ish , j , k1 , k2 ,
     &        nhep1 , nlines

      INTEGER indx(500) , indx_max

      DOUBLE PRECISION DT_RNDM
      INTEGER IPHO_PDG2ID
      EXTERNAL DT_RNDM , IPHO_PDG2ID

      DOUBLE PRECISION PYP , rqlun
      INTEGER PYK
      EXTERNAL PYP, PYK

      INCLUDE 'inc/pydat1'
      INCLUDE 'inc/pyint1'
      INCLUDE 'inc/pyjets'

      DIMENSION ijoin(MSCAHD)

      Irej = 0
      IF ( ABS(ISWmdl(6)).GT.3 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A,I3)')
     &        'PHO_STRFRA:ERROR: ' , 'invalid value of ISWMDL(6)' ,
     &        ISWmdl(6)
         CALL PHO_ABORT
      END IF

Cc**anfe Reset internal popcorn flags before fragmentation
      DO i = 1 , 5
         MSTu(120+i) = 0
      END DO

C  popcorn suppression
C        IF(PARMDL(134).GT.0.D0) THEN
C          IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
C            MSTJ(12) = 2
C          ELSE
C            MSTJ(12) = 1
C          ENDIF
C        ENDIF

C  copy partons to fragmentation code JETSET
      ip = 0
      ip_old = 1

      DO j = 1 , ISTr

C  select partons with common production process
         igen = NPOs(4,j)
         IF ( igen.GE.0 ) THEN

            indx_max = 0
            DO i = j , ISTr
               IF ( (igen.EQ.NPOs(4,i)) .OR. (IPAmdl(17).EQ.0) ) THEN

C  write final particles/resonances to JETSET
                  IF ( NCOde(i).EQ.-99 ) THEN
                     ii = NPOs(1,i)
                     ip = ip + 1
                     P(ip,1) = PHEp(1,ii)
                     P(ip,2) = PHEp(2,ii)
                     P(ip,3) = PHEp(3,ii)
                     P(ip,4) = PHEp(4,ii)
                     P(ip,5) = PHEp(5,ii)
                     K(ip,1) = 1
                     K(ip,2) = IDHep(ii)
                     K(ip,3) = 0
                     K(ip,4) = 0
                     K(ip,5) = 0
                     IPHist(2,ii) = ip

                     IF ( indx_max.EQ.500 ) THEN
                        IF ( LPRi.GT.4 ) WRITE (LO,'(1x,2a,i8,I12)')
     &                        'PHO_STRFRA: ' ,
     &                     'no space left in index vector (indx,Kevent)'
     &                     , indx_max , KEVent
                        Irej = 1
                        RETURN
                     END IF

                     indx_max = indx_max + 1
                     indx(indx_max) = ii
C  write partons to JETSET
                  ELSE IF ( NCOde(i).GE.0 ) THEN
                     k1 = JMOhep(1,NPOs(1,i))
                     k2 = MAX(JMOhep(1,NPOs(1,i)),-JMOhep(2,NPOs(1,i)))
                     ij = 0
                     DO ii = k1 , k2
                        ip = ip + 1
                        P(ip,1) = PHEp(1,ii)
                        P(ip,2) = PHEp(2,ii)
                        P(ip,3) = PHEp(3,ii)
                        P(ip,4) = PHEp(4,ii)
                        P(ip,5) = PHEp(5,ii)
                        K(ip,1) = 1
                        K(ip,2) = IDHep(ii)
                        K(ip,3) = 0
                        K(ip,4) = 0
                        K(ip,5) = 0
                        IPHist(2,ii) = ip
                        ij = ij + 1
                        ijoin(ij) = ip
                        indx_max = indx_max + 1
                        indx(indx_max) = ii

                     END DO
                     ii = JMOhep(2,NPOs(1,i))
                     IF ( (ii.GT.0) .AND. (ii.NE.k1) ) THEN
                        ip = ip + 1
                        P(ip,1) = PHEp(1,ii)
                        P(ip,2) = PHEp(2,ii)
                        P(ip,3) = PHEp(3,ii)
                        P(ip,4) = PHEp(4,ii)
                        P(ip,5) = PHEp(5,ii)
                        K(ip,1) = 1
                        K(ip,2) = IDHep(ii)
                        K(ip,3) = 0
                        K(ip,4) = 0
                        K(ip,5) = 0
                        IPHist(2,ii) = ip
                        ij = ij + 1
                        ijoin(ij) = ip
                        indx_max = indx_max + 1
                        indx(indx_max) = ii

                     END IF
                     N = ip
C  connect partons to strings

                     CALL PYJOIN(ij,ijoin)

                  END IF

                  NPOs(4,i) = -NPOs(4,i)
               END IF
            END DO

C  set Lund counter
            N = ip
            IF ( ip.NE.0 ) THEN

C  hard final state evolution
               IF ( (ISWmdl(8).EQ.1) .OR. (ISWmdl(8).EQ.3) ) THEN
                  ish = 0
                  DO k1 = 1 , indx_max
                     i = indx(k1)
                     IF ( IPHist(1,i).LE.-100 ) THEN
C**anfe  Added bounds check for IJOIN
                        IF ( ish.LE.MSCAHD ) THEN
                           ish = ish + 1
                           ijoin(ish) = i
                        ELSE
                           IF ( LPRi.GT.4 ) WRITE (LO,'(1x,2A,2I5)')
     &                         'PHO_STRFRA:ERROR: ' ,
     &                        'no space left in IJOIN (ISH,MSCAHD)' ,
     &                        ish , MSCAHD
                           CALL PHO_ABORT
                        END IF
                     END IF
                  END DO
                  IF ( ish.GE.2 ) THEN
                     DO k1 = 1 , ish
                        IF ( ijoin(k1).NE.0 ) THEN
                           i = ijoin(k1)
                           IF ( (IPAmdl(102).NE.1) .OR.
     &                        (IPHist(1,i).EQ.-100) ) THEN
                              DO k2 = k1 + 1 , ish
                               IF ( ijoin(k2).NE.0 ) THEN
                               ii = ijoin(k2)
                               IF ( IPHist(1,i).EQ.IPHist(1,ii) ) THEN
                               pt1 = SQRT(PHEp(1,ii)**2+PHEp(2,ii)**2)
                               pt2 = SQRT(PHEp(1,i)**2+PHEp(2,i)**2)
                               rqlun = MIN(pt1,pt2)

                               IF ( LPRi.GT.4 .AND. IDEb(22).GE.10 )
     &                            WRITE (LO,'(1X,A,2I5,E12.4)')
     &                             'PHO_STRFRA: PYSHOW called' , i ,
     &                            ii , rqlun
                               CALL PYSHOW(IPHist(2,i),IPHist(2,ii),
     &                            rqlun)

                               ijoin(k1) = 0
                               ijoin(k2) = 0
                               GOTO 2
                               END IF
                               END IF
                              END DO
                           END IF
                        END IF
 2                   END DO
                  END IF
               END IF

C  fragment parton / hadron configuration (hadronization & decay)

               IF ( ISWmdl(6).NE.0 ) THEN
                  ii = MSTu(21)
                  MSTu(21) = 1

                  CALL PYEXEC

                  MSTu(21) = ii
C  Lund warning?
                  IF ( MSTu(28).NE.0 ) THEN
                     IF ( IDEb(22).GE.10 ) THEN
                        IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I12,I3)')
     &                      'PHO_STRFRA:(1) Lund code warning (EV/code)'
     &                      , KEVent , MSTu(28)
                        CALL PHO_PREVNT(2)
                     END IF
                  END IF
C  event accepted?
                  IF ( MSTu(24).NE.0 ) THEN
                     IF ( IDEb(22).GE.2 ) THEN
                        IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I12,I3)')
     &                 'PHO_STRFRA:(1) rejection by Lund code (EV/code)'
     &                 , KEVent , MSTu(24)
                        CALL PHO_PREVNT(2)
                     END IF
                     Irej = 1
                     RETURN
                  END IF
               END IF

               ip = N
C  change particle status in JETSET to avoid internal adjustments
               DO k1 = ip_old , ip
                  K(k1,1) = K(k1,1) + 1000
               END DO
               ip_old = ip + 1
            END IF
         END IF

      END DO

C  restore original JETSET particle status codes
      DO i = 1 , N
         K(i,1) = K(i,1) - 1000
      END DO

C       IF(IDEB(22).GE.25) THEN
C         WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
C    &      'particle/string system before fragmentation'
C         CALL PHO_PREVNT(2)
C       ENDIF

C  copy hadrons back to POEVT1 / POEVT2

      IF ( ip.GT.0 ) THEN
         nhep1 = NHEp + 1

         nlines = PYK(0,1)

C  copy hadrons back with full history information
         IF ( IPAmdl(178).EQ.1 ) THEN
            DO ii = 1 , ISTr
               IF ( NCOde(ii).GE.0 ) THEN
                  k1 = IPHist(2,NPOs(2,ii))
                  k2 = IPHist(2,-NPOs(3,ii))
               ELSE IF ( NCOde(ii).EQ.-99 ) THEN
                  k1 = IPHist(2,NPOs(1,ii))
                  k2 = k1
               ELSE
                  GOTO 20
               END IF
               ifound = 0
               DO j = 1 , nlines

                  IF ( PYK(j,7).EQ.1 ) THEN
                     ipmoth = PYK(j,15)

                     IF ( (ipmoth.GE.k1) .AND. (ipmoth.LE.k2) ) THEN

                        ibam = IPHO_PDG2ID(PYK(j,8))

                        IF ( (ibam.EQ.0) .AND. (ISWmdl(6).NE.0) ) THEN
                           IF ( IDEb(22).GE.2 ) THEN
                              IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A)')
     &                            'PHO_STRFRA: ' ,
     &                           'LUND interface (1) rejection'
                              CALL PHO_PREVNT(2)
                           END IF
                           Irej = 1
                           RETURN
                        END IF
                        ifound = ifound + 1

                        px = PYP(j,1)
                        py = PYP(j,2)
                        pz = PYP(j,3)
                        he = PYP(j,4)
                        xmb = PYP(j,5)**2

C  register parton/hadron
                        is = 1
                        IF ( ibam.EQ.0 ) THEN
                           IF ( ISWmdl(6).EQ.0 ) THEN
                              is = -1
                           ELSE
                              IF ( IDEb(22).GE.2 ) THEN
                               IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A)')
     &                             'PHO_STRFRA: ' ,
     &                            'LUND interface (2) rejection'
                               CALL PHO_PREVNT(2)
                              END IF
                              Irej = 1
                              RETURN
                           END IF
                        END IF

                        CALL PHO_REGPAR(is,PYK(j,8),ibam,NPOs(1,ii),0,
     &                     px,py,pz,he,j,0,0,0,ipos,1)

                        ISThep(ipos) = 1
                     END IF
                  END IF
               END DO
               IF ( ifound.EQ.0 ) THEN
                  IF ( IDEb(2).GE.2 ) THEN
                     IF ( LPRi.GT.4 ) WRITE (LO,'(2A,I12,I3)')
     &                     'PHO_STRFRA: ' ,
     &                    'no particles found for string (EVE,ISTR):' ,
     &                    KEVent , ii
                  END IF
                  ISThep(NPOs(1,ii)) = 2
               END IF
 20         END DO
         ELSE
C  copy hadrons back without history information
            JDAhep(1,1) = nhep1
            JDAhep(1,2) = nhep1
            DO j = 1 , nlines

               IF ( PYK(j,7).EQ.1 ) THEN
                  ibam = IPHO_PDG2ID(PYK(j,8))

                  IF ( (ibam.EQ.99999) .AND. (ISWmdl(6).NE.0) ) THEN
                     IF ( IDEb(22).GE.2 ) THEN
                        IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A)')
     &                        'PHO_STRFRA: LUND interface (3) rejection'
                        CALL PHO_PREVNT(2)
                     END IF
                     Irej = 1
                     RETURN
                  END IF

                  px = PYP(j,1)
                  py = PYP(j,2)
                  pz = PYP(j,3)
                  he = PYP(j,4)
                  xmb = PYP(j,5)**2

C  register parton/hadron
                  is = 1
                  IF ( ibam.EQ.0 ) THEN
                     IF ( ISWmdl(6).EQ.0 ) THEN
                        is = -1
                     ELSE
                        IF ( IDEb(22).GE.2 ) THEN
                           IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A)')
     &                        'PHO_STRFRA: LUND interface (4) rejection'
                           CALL PHO_PREVNT(2)
                        END IF
                        Irej = 1
                        RETURN
                     END IF
                  END IF

                  CALL PHO_REGPAR(is,PYK(j,8),ibam,1,2,px,py,pz,he,j,0,
     &               0,0,ipos,1)

                  ISThep(ipos) = 1
               END IF
            END DO
            DO ii = 1 , ISTr
               IF ( (NCOde(ii).GE.0) .OR. (NCOde(ii).EQ.-99) )
     &              ISThep(NPOs(1,ii)) = 2
            END DO
         END IF
      END IF

C  debug event status
      IF ( IDEb(22).GE.15 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(//1X,A)')
     &         'PHO_STRFRA: particle system after fragmentation'
         CALL PHO_PREVNT(2)
      END IF

      END SUBROUTINE


subroutine crop_endseason(bc0nam,bm0cfl,bnslay,bc0idc,bcdayam,bcthum,bcxstmrep, &
                        & bprevstandstem,bprevstandleaf,bprevstandstore,        &
                        & bprevflatstem,bprevflatleaf,bprevflatstore,           &
                        & bprevbgstemz,bprevrootstorez,bprevrootfiberz,bprevht, &
                        & bprevstm,bprevrtd,bprevdayap,bprevhucum,bprevrthucum, &
                        & bprevgrainf,bprevchillucum,bprevliveleaf,bcdayspring, &
                        & mature_warn_flg,acycon,acynmu,ies,joints,boots,heads, &
                        & antss,mats,hrs,phenolflg)
!
!debe passed acycon from main to print out the calculated yield. acycon is needed
!for the calculation. acycon is the conversion factor.
!debe passed in antss, hrs, ies, joints, and mats for printing out these growth
! stage arrays for anthesis, harvest ready, internode elongation, jointing and
! maturity. other growth stage arrays will need to be added for other crops.
!
implicit none
!
include 'file.fi'
!
! Dummy arguments
!
real :: acycon,bcthum,bcxstmrep,bprevchillucum,bprevflatleaf,bprevflatstem,     &
      & bprevflatstore,bprevgrainf,bprevht,bprevhucum,bprevliveleaf,bprevrtd,   &
      & bprevrthucum,bprevstandleaf,bprevstandstem,bprevstandstore,bprevstm
character(6) :: acynmu
integer :: bc0idc,bcdayam,bcdayspring,bm0cfl,bnslay,bprevdayap,mature_warn_flg, &
         & phenolflg
character(80) :: bc0nam
integer,dimension(4) :: antss,boots,heads,hrs,ies,joints,mats
real,dimension(*) :: bprevbgstemz,bprevrootfiberz,bprevrootstorez
!
! Local variables
!
real :: bg_stem_sum,hi,hui,root_fiber_sum,root_store_sum,totbiomass,yield
integer :: dd,lay,mm,yy
!
!debe added declaration of acynum to print out units for current crop yield.
!
! local variables
!
!debe added declaration of local variable yield. also totbiomass for
! for calculating the final total biomass and hi for calculating the
! harvest index.
!
!     the following subroutine arguments are not used: bprevliveleaf,
!     bprevrthucum     jcaii  8/08/08
!
!     + + + purpose + + +
!     prints out crop status variables that are of interest at the end of the season

!     + + + keywords + + +
!     crop model status

!     + + + argument declarations + + +
!     acycon - conversion factor from kg/m^2 to units named in acynmu (all
!              dry weight)
!     bc0nam - crop name
!     bm0cfl - flag to print crop submodel output
!     bnslay - number of soil layers
!     bc0idc - crop type:annual,perennial,etc
!     bcdayam - number of days since crop matured
!     bcthum - potential heat units for crop maturity (deg. c)
!     bcxstmrep - a representative diameter so that
!                 acdstm*acxstmrep*aczht=acrsai
!     bprevbgstemz - crop stem mass below soil surface by layer
!     bprevchillucum - accumulated chilling units
!     bprevdayap - number of days of growth completed since crop planted
!     bprevflatleaf - crop flat leaf mass
!     bprevflatstem - crop flat stem mass
!     bprevflatstore - crop flat storage mass
!     bprevgrainf - internally computed grain fraction of reproductive
!                   mass
!     bprevht - crop height
!     bprevhucum - crop accumulated heat units
!     bprevliveleaf - fraction of standing plant leaf which is living
!                     (transpiring). not currently used.
!     bprevrootfiberz - crop root fibrous mass by soil layer
!     bprevrootstorez - crop root storage mass by soil layer
!                       (tubers (potatoes, carrots), extended leaf
!                       (onion), seeds (peanuts)).
!     bprevrtd - crop root depth
!     bprevrthucum - crop accumulated heat units with no
!                    vernalization/photoperiod delay. not currently used.
!     bprevstandleaf - crop standing leaf mass
!     bprevstandstem - crop standing stem mass
!     bprevstandstore - crop standing storage mass (head with seed, or
!                       vegetative head (cabbage, pineapple))
!     bprevstm - number of crop stems per unit area. it is computed by
!                taking the tillering factor times the plant population
!                density.
!     bcdayspring - day of year in which a winter annual releases stored
!                   growth
!     mature_warn_flg - flag to indicate use of crop maturity warning
!                0  - no crop maturity warning given for any crop
!                1  - warnings generated for any crop unless supressed
!                     by crop type

!     + + + global common blocks + + +

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     bg_stem_sum - sum of below ground stem
!     dd - the current day
!     hi - harvest index. yield/totbiomass
!     hui - heat unit index (ratio of acthucum to acthum)
!     lay - loop counter
!     mm -  the current month
!     root_fiber_sum - sum of root fiber
!     root_store_sum - sum of root storage
!     yield - the calculated yield of the crop.
!             yield = bprevstandstore*acycon*bprevgrainf
!     totbiomass - the final total biomass.
!       totbiomass = bprevstandleaf+bprevstandstem+bprevstandstore+
!                    bprevflatleaf+bprevflatstem+bprevflatstore
!     yy - the current year
!
!     + + + newly added variables + + +
!     antss - start of anthesis growth stage for corn, dry beans, hay millet,
!             proso millet, sorghum (first bloom), spring barley, spring
!             wheat, sunflower, winter barley and winter wheat. in dry beans,
!             the start of anthesis growth stage and there is one open
!             flower per plant =100% bloom. this array includes daynum,
!             year, month and day of when this stage was reached.
!     hrs - time to harvest ripe growth stage for corn, dry beans, hay
!           millet, proso millet, sorghum, spring barley, spring wheat,
!           sunflower, winter barley and winter wheat. in dry beans, 80%
!           of pods are at the mature color in dry beans. this array
!           includes daynum, year, month and day of when this stage was
!           reached.
!     ies - start of internode elongation growth stage for corn, hay millet,
!           proso millet, sorghum, spring barley, spring wheat, winter barley,
!           and winter wheat. for sunflower, this stage occurs when the
!           internode below the inflorescence elongates 0.5 to 2.0 cm above
!           the nearest leaf on the stem. this array includes daynum, year,
!           month and day of when this stage was reached.
!     joints - jointing growth stage for hay millet, proso millet, sorghum,
!              spring barley, spring wheat, winter barley and winter wheat.
!              this array includes daynum, year, month and day of when this
!              stage was reached.
!     mats - physiological maturity growth stage for corn, dry beans,
!            hay millet, proso millet, sorghum, spring barley, spring
!            wheat, sunflower, winter barley and winter wheat. in dry beans,
!            one pod has changed color/striped. this array includes
!            daynum, year, month and day of when this stage was reached.
!     phenolflg - a flag that determines if the upgm/weps method of determining maturity
!                 will be used (phenolflg =0) or the phenologymms method will be used (phenolflg = 1).
!     + + + end of specifications + + +

!     day of year

  !phenolflg1 = 0
  !mats1 = 170
  !
call caldatw(dd,mm,yy)

      ! end of season print statements when crop submodel output flag set
      ! added initialization flag to prevent printing if crop not yet initialized
 !print*, 'in crop_endseason and bprevhucum = ', bprevhucum, 'bcthum = ', bcthum

if ((bcthum>0.0).and.(phenolflg==0)) then
  hui = bprevhucum/bcthum
 ! print*, 'in crop_endseason hui = ', hui
else if ((bcthum>0.0).and.(phenolflg==1).and.(mats(1)/=999)) then
  hui = 1.0
 ! print*, 'in crop_endseason hui = ', hui
else
  hui = 0.0
end if

      ! print end-of-season (before harvest) crop state
if ((bm0cfl>=0)) then            ! always print this one now - lew
  bg_stem_sum = 0.0
  root_store_sum = 0.0
  root_fiber_sum = 0.0
  do lay = 1,bnslay
     bg_stem_sum = bg_stem_sum + bprevbgstemz(lay)
     root_store_sum = root_store_sum + bprevrootstorez(lay)
     root_fiber_sum = root_fiber_sum + bprevrootfiberz(lay)
  end do
!debe added yield to hold the calculated yield value for the current crop
! and added it to the following write statement and format statment.
!this puts yield in the units for which yield is reported for the current
!  crop.
  yield = bprevstandstore*acycon*bprevgrainf

! debe will need to use the yield units variable (acynmu) to print the units
! next to the yield value instead of above it in cpout because the units
! vary among crops and so there is not a constant value to print in the
! output subroutine cpout as text. couldn't get the variable 'acynmu' to be
! used in cpout to print the current yield units for the current crop.

!debe added calculation for final total biomass. add it to write and
!   format statements. this is in kg/m^2
  totbiomass = bprevstandleaf + bprevstandstem + bprevstandstore +              &
             & bprevflatleaf + bprevflatstem + bprevflatstore

!debe added calculation for hi (harvest index). add it to write
! and format statements. yield and totbiomass are likely in
! different units. multiply totbiomass by the conversion factor so that
! yield and totbiomass are in the same units.

  hi = yield/(totbiomass*acycon)

  write (luoseason,1000) yy,bprevstandstem,bprevstandleaf,bprevstandstore,      &
                       & bprevflatstem,bprevflatleaf,bprevflatstore,bg_stem_sum,&
                       & root_store_sum,root_fiber_sum,bprevht,bprevstm,        &
                       & bprevrtd,bprevgrainf,bcxstmrep,bprevdayap,             &
                       & bprevchillucum,bprevhucum,bcthum,hui,bcdayam,          &
                       & bcdayspring,bc0nam,yield,acynmu,totbiomass,hi,ies(1),  &
                       & joints(1),boots(1),heads(1),antss(1),mats(1),hrs(1)
end if

      ! for annual crops, always write out warning message
      ! if harvested before maturity
if ((hui<1.0).and.(mature_warn_flg>0).and.                                      &
  & ((bc0idc==1).or.(bc0idc==2).or.(bc0idc==4).or.(bc0idc==5)))                 &
  & write (unit=6,fmt='(1x,3(a),i2,''/'',i2,''/'',i2,a,f5.1,a,a)') 'warning: ', &
  & bc0nam(1:len_trim(bc0nam)),' harvested ',dd,mm,yy,' only reached ',         &
  & hui*100.0,'% of maturity',' (check crop selection, planting, harvest dates)'

!     + + + output formats + + +
 1000 format (1x,i4,13(1x,f7.3),1x,f7.5,1x,i4,3(1x,f6.1),1x,f5.3,1x,i4,1x,i6,1x,&
            & a12,1x,f7.2,7x,a3,'/ac',2x,f7.3,9x,f5.3,11x,i3,13x,i3,5x,i3,5x,i3,&
            & 6x,i3,6x,i3,7x,i3)
!debe added formatting to output yield, units, totbiomass, hi
!
end subroutine crop_endseason


c     ****************************************************************
c     *                                                              *
c     *                      subroutine kgstiff                      *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified :  3/15/2017 rhd             *
c     *                                                              *
c     *     for this element block, this integration point,          *
c     *     compute gemetric stiffness and add to [Ke]               *
c     *     handles [ke] in symmetric and asymmetric forms           *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine kgstiff( span, cp, icp, gama, nxi, neta, nzeta, nnode,
     &                sig, dj, w, ek_full, ek_symm, vol, bbar,
     &                totdof )
      use main_data, only: asymmetric_assembly
      implicit none
      include 'param_def'
c
c                       parameter declarations
c
      integer :: span, cp(*), icp(mxutsz,*), nnode, totdof
      double precision ::
     &    gama(mxvl,ndim,*), nxi(*), neta(*), nzeta(*), sig(mxvl,*),
     &    dj(*), ek_full(span,*), ek_symm(span,*), w, vol(mxvl,8,*)
      logical :: bbar
c
c                       locally arrays - on stack
c
      integer :: j, i, cp1, cp2, cp3, k, enode,
     &           r1, c1, k1, r2, c2, k2, r3, c3, k3
      logical :: symmetric_assembly
      double precision
     &    gtg(mxvl,mxnusz), gxi(mxvl,mxndel),
     &    geta(mxvl,mxndel), gzeta(mxvl,mxndel)
c
c              the geometric stiffness, trans([G[) [M] [G] is
c              symmetric. calculate building blocks then use separate
c              paths to update [Ke] based on its symmetry/asymmetry.
c
      symmetric_assembly = .not. asymmetric_assembly
c
      if( bbar ) then
        do j = 1, nnode
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
          do i = 1, span
           gxi(i,j)   = vol(i,j,1)
           geta(i,j)  = vol(i,j,2)
           gzeta(i,j) = vol(i,j,3)
          end do
        end do
      else
        do j = 1, nnode
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
          do i = 1, span
            gxi(i,j)  =  gama(i,1,1)*nxi(j)+gama(i,1,2)*neta(j)+
     &                   gama(i,1,3)*nzeta(j)
            geta(i,j) =  gama(i,2,1)*nxi(j)+gama(i,2,2)*neta(j)+
     &                   gama(i,2,3)*nzeta(j)
            gzeta(i,j) = gama(i,3,1)*nxi(j)+gama(i,3,2)*neta(j)+
     &                   gama(i,3,3)*nzeta(j)
          end do
        end do
      end if
c
c              the gemetric stiffness has an unusual, repeated
c              structure with many of the smae submatrices added
c              multiple times into [Ke]
c
c              get geometric stiffness for one (x,y,z) direction.
c              others are identical.
c              Example. 8-node hex. a row of gtg contains the upper-
c              triangle of the 8 x 8 geometric stiffnessfor a dof. the
c              row is the same for other two dof. Thus, cols j=1->8
c              have row 1 of gtg, cols 9-15 have row 2, etc of the
c              upper-triangle.
c
      do j = 1, cp(nnode)+nnode
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
         do i = 1, span
            gtg(i,j)= (gxi(i,icp(j,1))*gxi(i,icp(j,2))*sig(i,1)+
     &                 geta(i,icp(j,1))*geta(i,icp(j,2))*sig(i,2)+
     &                 gzeta(i,icp(j,1))*gzeta(i,icp(j,2))*sig(i,3)+
     &                (gxi(i,icp(j,1))*geta(i,icp(j,2))+
     &                 gxi(i,icp(j,2))*geta(i,icp(j,1)))*sig(i,4)+
     &                (geta(i,icp(j,1))*gzeta(i,icp(j,2))+
     &                 geta(i,icp(j,2))*gzeta(i,icp(j,1)))*sig(i,5)+
     &                (gxi(i,icp(j,1))*gzeta(i,icp(j,2))+
     &                 gxi(i,icp(j,2))*gzeta(i,icp(j,1)))*sig(i,6))*
     &                 dj(i)*w
         end do
      end do
c
c              add to the symmetric [Ke]
c
      if( symmetric_assembly) then
        do enode = 1, nnode ! all element nodes
         cp1 = cp(enode)
         cp2 = cp(nnode+enode)+nnode
         cp3 = cp(2*nnode+enode)+2*nnode
c
         do j = 1, enode
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
            do  i = 1, span
               ek_symm(i,cp1+j) = ek_symm(i,cp1+j) + gtg(i,cp1+j)
               ek_symm(i,cp2+j) = ek_symm(i,cp2+j) + gtg(i,cp1+j)
               ek_symm(i,cp3+j) = ek_symm(i,cp3+j) + gtg(i,cp1+j)
            end do
         end do ! j over element nodes
       end do  ! over element nodes
       return
      end if
c
c               add to the asymmetric assembly. this is more difficult
c               coding since only the upper-triangle of gtg is
c               computed above. so we have loops to add upper-triangle
c               gtg terms again into lower trangle of the asymmetric
c               [Ke]. this algortihm keeps ifs out of inner loops and
c               has stride 1 access all arrays.
c
      do enode = 1, nnode
c
         cp1 = cp(enode)
         c1  = enode
         c2  = nnode + enode
         c3  = 2*nnode + enode
c
         do j = 1, enode
c
           r1 = j
           k1 = (c1-1)*totdof + r1
c
           r2 = nnode + j
           k2 = (c2-1)*totdof + r2
c
           r3 = 2*nnode + j
           k3 = (c3-1)*totdof + r3
c
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
           do  i = 1, span! col enode, row j
             ek_full(i,k1) = ek_full(i,k1) + gtg(i,cp1+j)
             ek_full(i,k2) = ek_full(i,k2) + gtg(i,cp1+j)
             ek_full(i,k3) = ek_full(i,k3) + gtg(i,cp1+j)
           end do
c
           if( r1 .ne. c1 ) then  ! cleanup loop 1
             k = (r1-1)*totdof + c1
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
             do i = 1, span
               ek_full(i,k) = ek_full(i,k) + gtg(i,cp1+j)
             end do
           end if
c
           if( r2 .ne. c2 ) then  ! cleanup loop 2
             k = (r2-1)*totdof + c2
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
             do i = 1, span
               ek_full(i,k) = ek_full(i,k) + gtg(i,cp1+j)
             end do
           end if
c
           if( r3 .ne. c3 ) then  ! cleanup loop 3
              k = (r3-1)*totdof + c3
!DIR$ IVDEP
!DIR$ VECTOR ALIGNED
              do i = 1, span
                ek_full(i,k) = ek_full(i,k) + gtg(i,cp1+j)
              end do
           end if
c
         end do ! over j
      end do ! over enode
c
      return
      end


	SUBROUTINE GSCOLB ( icbank, icolr, iret )
C************************************************************************
C* GSCOLB								*
C* 									*
C* This subroutine sets the color number in a color bank. The current	*
C* color banks are:							*
C*			0 = graphics					*
C*			1 = satellite images				*
C*			2 = radar images				*
C*									*
C* Graphics color numbers larger than the number of valid colors will	*
C* be converted, via modular arithmetic, to a valid color number.  If	*
C* the color number is negative or zero, no change will be made.	*
C* This routine replaces gscolr.					*
C* 									*
C* GSCOLB  ( ICBANK, ICOLR, IRET )					*
C*									*
CC*									*
C* Input parameters:							*
C*	ICBANK		INTEGER		Color bank			*
C* 	ICOLR		INTEGER		Color number			*
C* 					  <= 0 = no change		*
C*									*
C* Output parameters:							*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* J. Cowie/COMET	 5/95	After GSCOLR()				*
C* M. Linda/GSC		 2/97	Removed GFLUSH				*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'DEVCHR.CMN'
	INCLUDE		'DEVREQ.CMN'
	INCLUDE		'DEVSET.CMN'
C*
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	If this is a new color bank, save it in common.
C
	IF ( icbank .ne. kcbank ) kcbank = icbank
C
C*	For non-graphics colors, set the color directly
C
	IF ( icbank .gt. 0 ) THEN
C
C*	    Call color setting routine
C
	    CALL DSCOLB ( icbank, icolr, ier )
	    kcolr = 0
	    lcolr = 0
	    RETURN
C
	END IF
C
C*	First check if this is the current requested color.
C*	If so, do nothing.
C
	IF  ( icolr .eq. kcolr ) THEN
C
C*	    Check if this is the current set color.  If so, save
C*	    as requested color.
C
	  ELSE IF  ( icolr .eq. lcolr ) THEN
	    kcolr = icolr
C
C*	    If the color is negative or zero, ignore.
C
	  ELSE IF  ( icolr .le. 0 ) THEN
C*
	  ELSE
C
C*	    Save the color as the requested color.
C
	    kcolr  = icolr
C
C*	    Make this the active color only if the device has been set.
C
	    IF  ( ddev .ne. ' ' ) THEN
C
C*	        Compute the color number to be set.
C
	        ijcolr = MOD ( icolr, nncolr )
	        IF  ( ijcolr .eq. 0 )  ijcolr = nncolr
		IF  ( icolr .eq. 101 )  ijcolr = icolr
		lcolr = ijcolr
	    END IF
	END IF
C*
	RETURN
	END


C
      SUBROUTINE DETABS(J,JP,NTP,IOUTR)
C
* New version including improvements of CIA, now tabulated into jonabs.dat
* as well as new sources: MgIff, SiIff, and MeIff (other metals)
* OH and CH continuous opac from Kurucz are also in jonabs now.
* from Uppsala version of KE+BE
*      BPz 19/09-2007
*     MARCS v07.3
*
* included Borysow H2-H2 and H2-He opacities. logical switch
* borysow allows choice between these and older ones (Linsky + Patch?)
* BPz 6/10/95.
* Updated 90.03.38 together with jonabs.dat /Bengt Gustafsson
* Data taken from Mathiesen, 1984, Publ. Ser. No. 1, Oslo ...
* parametrized in NDP and included to spherical code:
* VIKTR has been changed to VIKTR**(-1) and H2 scattering added.
*      11-may-90 BPz
* New OP and IRON data for FeI and FeII by Dan Kiselman 98-08-26
C        THIS ROUTINE GIVES THE DETAILS OF THE ABSORPTION MECHANISMS.
C        CHANGES IN THE ABSORPTION-COEFFICIENT PROGRAM ARE EXPECTED TO
C        BE CONFINED TO THE TABLES AND TO THIS ROUTINE.
C        DETABS HAS TWO PURPOSES
C        1. JP=0   DETERMINATION OF WAVELENGTH-INDEPENDENT FACTORS (DEP.ON
C                  T, PE AND THE COMPONENT) STORED IN FAKT.
C        2. JP= THE ACTUAL WAVELENGTH NUMBER.
C                  MULTIPLICATION OF AB, COMPUTED IN SUBROUTINE ABSKO,
C                  BY WAVELENGTH-DEPENDENT FACTORS. SUMMATION OF THE TOTAL
C                  ABSORPTION AND SCATTERING COEFFICIENTS ( SUMABS AND
C                  SUMSCA ).
C
C        N O T E .  BEFORE A CALL ON DETABS FOR PURPOSE 1, SUBROUTINE
C        JON MUST HAVE BEEN CALLED.
C
C        IF J IS LESS THAN OR EQUAL TO ZERO, THE WEIGHT FOR A ROSSELAND MEAN
C        WILL BE COMPUTED AND STORED IN VIKTR (THE WEIGHT BEING 1/VIKTR).
C        NTP IS THE ARRAY INDEX OF THE T-PE POINT.
C        IF IOUTR IS GREATER THAN ZERO AT A CALL WITH JP GREATER THAN ZERO
C        (PART TWO OF THE ROUTINE), DETAILS OF THE ABSORPTION COEFFICIENTS
C        ARE PRINTED. IF IOUTR IS GREATER THAN ONE, A TABLE HEADING IS ALSO
C        PRINTED.
C
C
C        CONTENTS OF COMMON/CI5/, COMMUNICATING PHYSICAL INFORMATION FROM
C        SUBROUTINE JON.
C             ABUND  ABUNDANCES
C             ANJON  FRACTIONS OF IONIZATION
C             H      QUANTUM NUMBER OF THE HIGHEST EXISTING HYDROGENIC LEVEL
C             PART   PARTITION FUNCTIONS
C             DXI    DECREASE OF IONIZATION ENERGY OF HYDROGEN IN ELECTRON VOLTS
C             F1     N(HI)/N(H)
C             F2     N(HII)/N(H)
C             F3     N(H-)/N(H)
C             F4     N(H2+)/N(H)
C             F5     N(H2)/N(H)
C             XKHM   'DISSOCIATION CONSTANT' OF H-
C             XMH    MASS OF THE HYDROGEN ATOM IN GRAMS
C             XMY    GRAMS OF STELLAR MATTER/GRAMS OF HYDROGEN
C
C        DIMENSIONS NECESSARY
C        ABUND(NEL),ANJON(NEL,MAX(NJ)),ELS(NT),H(5),HREST(NT),PART(NEL,MAX(NJ)),
C        PROV(NKOMP)
C        THE DIMENSIONS ARE LOWER LIMITS. DIMENSIONS IN COMMON /CA5/ ARE
C        COMMENTED ON IN SUBROUTINE ABSKO.
C        NEL IS THE NUMBER OF CHEMICAL ELEMENTS INITIATED IN SUBROUTINE INJON
C        NJ(I) IS THE NUMBER OF STAGES OF IONIZATION, INCLUDING THE NEUTRAL
C             STAGE, FOR ELEMENT I
C        NKOMP IS THE NUMBER OF COMPONENTS, NOT INCLUDING THOSE ADDED BY
C             ANALYTICAL EXPRESSIONS AFTER STATEMENT NO. 13.
C        NT   IS THE NUMBER OF TEMPERATURES-ELECTRON PRESSURES GIVEN AT THE
C             CALL OF SUBROUTINE ABSKO.
C
C
*
      implicit none
*
      include 'spectrum.inc'
      include 'tsuji.par'
*
      real    ELS(ndp),HREST(ndp),FAKRAY(ndp),h2ray(ndp),rayh2,rayhe
      real    KT,LAMBDA3,heray(ndp)
      real    hn,addf,hmin,expa,teta,rayh,expj,stim,xray
      real    xniv,xm2,xm3,hnh,xray2,umc,teta31,xfakh
      real*8  rhokt
      real    omega,propac,h2pres,phtva(ndp),phel(ndp),hepres,
     &        ph2h(ndp),phhe(ndp),h2hpres,hhepres,presmetion
      integer ioutr,jp,kp,komp,nniv,j,m,ntp,n1,i
* common block declarations:
      real    ABUND(16),ANJON(16,5),H(5),PART(16,5),DXI,F1,F2,F3,F4     /ci5/
      real    F5,XKHM,XMH,XMY                                           /ci5/
      COMMON /CI5/ ABUND,ANJON,H,PART,DXI,F1,F2,F3,F4,F5,XKHM,XMH,XMY   /ci5/
*
      real    AB(mkomp),FAKT(mkomp),PE(ndp),T(ndp),XLA(20),XLA3(20),RO        /ca5/
      real    SUMABS,SUMSCA,VIKTR                                       /ca5/
      integer ISET,NLB                                                  /ca5/
      COMMON /CA5/AB,FAKT,PE,T,XLA,XLA3,RO,SUMABS,SUMSCA,VIKTR,ISET,NLB /ca5/
*
      integer IREAD,IWRIT                                               /utput/
      COMMON /UTPUT/ IREAD,IWRIT                                        /utput/
*
      real    PROV(mkomp)                                                  /carc4/
      integer nprova,nprovs,nprov                                       /carc4/
      COMMON /CARC4/ PROV,nprova,nprovs,nprov                           /carc4/
*
      real    ALES,BLES                                                 /ldopac/
      COMMON /LDOPAC/ ALES,BLES                                         /ldopac/

      real rho,xmytsuji,ejontsuji
      doubleprecision partryck,xmettryck,xiontryck,presneutral,
     &     presion,presion2,presion3
      character*20 nametryck
      common/rhotsu/rho,xmytsuji,ejontsuji
      common/fullequilibrium/partryck(ndp,maxmol),
     &       xmettryck(ndp,maxmet),xiontryck(ndp,maxmet),
     &       nametryck(maxmol)
      common/orderedpress/presneutral(ndp,100),presion(ndp,100),
     &                    presion2(ndp,100),presion3(ndp,100)
*
      CHARACTER*8 SOURCE,ABNAME
      COMMON /CHAR/ ABNAME(mkomp),SOURCE(mkomp)
      integer nkomp,kompla,kompr,komps
      real abkof
      COMMON/CA2/ABKOF(nabdim),KOMPLA(mkomp*20),KOMPR,KOMPS,NKOMP
      CHARACTER*8 NHMIN,NH2PR,NHEPR,NELS,NHRAY,NH2RAY,nh,NHERAY
      DATA NH2PR/'H2+H2'/,NHEPR/'He+H2'/,NELS/'e-sc'/,NHRAY/'H-sc'/,
     & NH2RAY/'H2sc'/,NHMIN/'H-'/,nh/' H'/,NHERAY/'He-sc'/
      LOGICAL FIRST,borysow
      DATA FIRST/.TRUE./
      data borysow/.true./
C
C SAVE ABSORPTION COMPONENT NAMES THE FIRST TIME DETABS IS CALLED
C
      if (FIRST) then
**********************************************
***        open(100,file='dumpopac.dat')
**********************************************
        ABNAME(1)=NHMIN
        ABNAME(2)=nh
        ABNAME(3)=ABNAME(17)
        DO 2 KOMP=20,NKOMP
    2   ABNAME(KOMP-16)=ABNAME(KOMP)
* this renaming is just to avoid printing all the separate H levels
        NPROVA=NKOMP-16+4
        ABNAME(NPROVA-3)=NH2PR
        ABNAME(NPROVA-2)=NHEPR
        abname(nprova-1)='H2+H'
        abname(nprova)='He+H'
        NPROVS=4
        NPROV=NPROVA+NPROVS
        ABNAME(NPROV-3)=NELS
        ABNAME(NPROV-2)=NHRAY
        ABNAME(NPROV-1)=NH2RAY
        ABNAME(NPROV)=NHERAY
        DO KOMP=1,NPROV
           PRINT*,ABNAME(KOMP)
        ENDDO
        FIRST=.FALSE.
      endif
*
      TETA=5040./T(NTP)
      HN=1./(XMH*XMY)
      IF(JP.GT.0) goto 7
C
C        1. COMPUTATION OF WAVELENGTH-INDEPENDENT QUANTITIES
C
      HNH=F1*HN
      rhokt=rho*1.38066d-16*t(ntp)
      kt=1.38066e-16*t(ntp)
***************************************************************************
*** alternative, strictement equivalente:
***      hnh=presneutral(ntp,1)/(rho*1.38066e-16*t(ntp))
*** xmytsuji est mieux que xmy
***      hn=1./(xmh*xmytsuji)
* ON POURRAIT CHANGER PART EN G0 G1 etc...
***************************************************************************
C        H-
! H- data in jonabs-v19.2 are in cm^2.  BPz 26/04-2019
!      fakt(1)=(1.d-18/rhokt)*partryck(ntp,1)
      fakt(1)=(1.d0/rhokt)*partryck(ntp,1)
      if (nametryck(1).ne.'H -') then
        print*,nametryck(1), 'should be H-'
        stop 'PROBLEM in detabs!'
      endif
      fakt(19)=pe(ntp)*presneutral(ntp,1)*(1.d-26/rhokt)
!
!  Suppress HI bf, as it is now integrated in hydropac.f   BPz 03/04-2019
!
C        HI
      TETA31=31.30364*TETA
      xfakh=(2.0898d-26/rhokt)*presneutral(ntp,1)/part(1,1)
      NNIV=15
      XNIV=15.
      IF(H(1).LT.XNIV)NNIV=INT(H(1))
      DO3 M=1,NNIV
        XM2=M*M
        XM3=XM2*FLOAT(M)
    3 FAKT(M+1)=XFAKH*EXP(-TETA31*(1.-1./XM2))/XM3
      FAKT(NNIV+1)=FAKT(NNIV+1)*AMIN1(H(1)-NNIV,1.)
!
      do m=2,nniv+1
        fakt(m)=0.0
      end do
!
! HI bf is now set to zero !
!
      IF(NNIV.GE.15) goto 6
    4 N1=NNIV+1
      DO5 M=N1,15
    5 FAKT(M+1)=0.
C
C        FREE-FREE HI ABSORPTION
    6 UMC=2.302585*DXI*TETA
      EXPJ=XFAKH*EXP(-TETA31+UMC)/(2.*TETA31)
      ADDF=EXP(TETA31/((FLOAT(NNIV)+0.5)**2)-UMC)-1.
      IF(H(1).LT.XNIV+0.5)ADDF=0.
      FAKT(18)=EXPJ
      HREST(NTP)=EXPJ*ADDF
C
C        H+H
* note ro == rho (set in jon)
      fakt(20)=(presneutral(ntp,1)*(1.d-25/rhokt))*
     &         (presneutral(ntp,1)*(1.e-25/kt))
C        H2+
      fakt(21)=(presneutral(ntp,1)*(1.d-20/rhokt))*
     &         (presion(ntp,1)*(1.e-20/kt))
C        H2- ff
      fakt(22)=pe(ntp)*partryck(ntp,2)/rhokt
      if (nametryck(2).ne.'H H') then
        print*,nametryck(2), 'should be H2'
        stop 'PROBLEM in detabs!'
      endif
C        He I
      fakt(23)=presneutral(ntp,2)/(rhokt*part(2,1))
* presneutral/(rho*k*T) = no of He I per gram stellar matter
C        He I ff
      fakt(24)=pe(ntp)*(1.e-20/kt)*presion(ntp,2)*(1.d-20/rhokt)
C        He- (stimulated emission included in table)
      fakt(25)=pe(ntp)*presneutral(ntp,2)*(1.d-26/rhokt)
C        C I
      fakt(26)=presneutral(ntp,6)/(rhokt*part(3,1))
C        C II
      fakt(27)=presion(ntp,6)/(rhokt*part(3,2))
C        C I ff
      fakt(28)=(pe(ntp)/kt)*presion(ntp,6)*(1.d-40/rhokt)
C        C II ff
      fakt(29)=(pe(ntp)/kt)*presion2(ntp,6)*(1.d-40/rhokt)
C        C- (stimulated emission included in table)
      fakt(30)=pe(ntp)*presneutral(ntp,6)*(1.d-27/rhokt)
C        N I
      fakt(31)=presneutral(ntp,7)/(rhokt*part(4,1))
C        N II
      fakt(32)=presion(ntp,7)/(rhokt*part(4,2))
C        N- (stimulated emission included in table)
      fakt(33)=pe(ntp)*presneutral(ntp,7)*(1.d-27/rhokt)
C        O I
      fakt(34)=presneutral(ntp,8)/(rhokt*part(5,1))
C        O II
      fakt(35)=presion(ntp,8)/(rhokt*part(5,2))
C        O- (stimulated emission included in table)
      fakt(36)=pe(ntp)*presneutral(ntp,8)*(1.d-26/rhokt)
C        CO-ff (stimulated emission included in table) BPz 1/10-1996
      fakt(37)=pe(ntp)*partryck(ntp,7)*(1.d-26/rhokt)
      if (nametryck(7).ne.'C O ') then
        print*,nametryck(7), 'should be CO'
        stop 'PROBLEM in detabs!'
      endif
C        H2O-ff (stimulated emission included in table) BPz 30/09-1996
      fakt(38)=pe(ntp)*partryck(ntp,4)*(1.d-26/rhokt)
      if (nametryck(4).ne.'H O H ') then
        print*,nametryck(4), 'should be H2O'
        stop 'PROBLEM in detabs!'
      endif
C        Mg I
      fakt(39)=presneutral(ntp,12)/(rhokt*part(8,1))
C        Mg II
      fakt(40)=presion(ntp,12)/(rhokt*part(8,2))
C        Al I
      fakt(41)=presneutral(ntp,13)/(rhokt*part(9,1))
C        Al II
      fakt(42)=presion(ntp,13)/(rhokt*part(9,2))
C        Si I
      fakt(43)=presneutral(ntp,14)/(rhokt*part(10,1))
C        Si II
      fakt(44)=presion(ntp,14)/(rhokt*part(10,2))
C        Ca I
      fakt(45)=presneutral(ntp,20)/(rhokt*part(13,1))
C        Ca II
      fakt(46)=presion(ntp,20)/(rhokt*part(13,2))
C        FE I
      fakt(17)=presneutral(ntp,26)/(rhokt*part(15,1))
C        FE II
      fakt(47)=presion(ntp,26)/(rhokt*part(15,2))
* presion/(rho*k*T) = no of Fe II per gram stellar matter
c        CH
      fakt(48)=partryck(ntp,6)*13.02/(6.023d23*rhokt)
      if (nametryck(6).ne.'C H') then
        print*,nametryck(6), 'should be CH'
        stop 'PROBLEM in detabs!'
      endif
c        OH
      fakt(49)=partryck(ntp,5)*17.01/(6.023d23*rhokt)
      if (nametryck(5).ne.'O H') then
        print*,nametryck(5), 'should be OH'
        stop 'PROBLEM in detabs!'
      endif
C        Mg I ff
      fakt(50)=(pe(ntp)/kt)*(presion(ntp,12)*(1.d-40/rhokt))
C        Si I ff
      fakt(51)=(pe(ntp)/kt)*(presion(ntp,14)*(1.d-40/rhokt))
C        Me I ff for the sum of all other metals; Al, Li-B, N-Na, P-U
C                using Peach G. 1970, Mem RAS 73,1 hydrogenic approx.
      presmetion=0.0
      do i=3,5
        if(presion(ntp,i).gt.0.0) presmetion=presmetion+presion(ntp,i)
      enddo
      do i=7,11
        if(presion(ntp,i).gt.0.0) presmetion=presmetion+presion(ntp,i)
      enddo
      if(presion(ntp,13).gt.0.0) presmetion=presmetion+presion(ntp,13)
      do i=15,92
        if(presion(ntp,i).gt.0.0) presmetion=presmetion+presion(ntp,i)
      enddo
      fakt(52)=(pe(ntp)/kt)*(presmetion*(1.d-40/rhokt))
* presmetion is similar to the MgII pressure almost throughout the Sun
**
C        ELECTRON SCATTERING
      ELS(NTP)=4.8206E-9*PE(NTP)/(T(NTP)*RO)
**
* added for cool stars -> collision induced absorption (CIA)
cc      ph2=f5*hn*ro
cc      ph2=ph2*1.38e-16*0.987e-6*273.
cc      phtva(ntp)=ph2*ph2/ro
      phtva(ntp)=(partryck(ntp,2)*273./t(ntp)*0.987e-6)*
     &           (partryck(ntp,2)*273./t(ntp)*0.987e-6)/rho
      if (nametryck(2).ne.'H H') then
        print*,nametryck(2), 'should be H2'
        stop 'PROBLEM in detabs!'
      endif
cc      PHEL(NTP)=(ABUND(2)/ABUND(1))*RO*HN/1.008
cc      PHEL(NTP)=PHEL(NTP)*1.38E-16*0.987E-6*273.
cc      PHEL(NTP)=PHEL(NTP)*PH2/RO
      phel(ntp)=(presneutral(ntp,2)*273./t(ntp)*0.987e-6)*
     &           (partryck(ntp,2)*273./t(ntp)*0.987e-6)/rho
      if (nametryck(2).ne.'H H') then
        print*,nametryck(2), 'should be H2'
        stop 'PROBLEM in detabs!'
      endif
      ph2h(ntp)=(presneutral(ntp,1)/t(ntp)*2.6945e-04)*
     &             (partryck(ntp,2)/t(ntp)*2.6945e-04)/rho
      if (nametryck(2).ne.'H H') then
        print*,nametryck(2), 'should be H2'
        stop 'PROBLEM in detabs!'
      endif
      phhe(ntp)=(presneutral(ntp,1)/t(ntp)*2.6945e-04)*
     &          (presneutral(ntp,2)/t(ntp)*2.6945e-04)/rho
**
C        RAYLEIGH SCATTERING
cc      FAKRAY(NTP)=HNH*2./PART(1,1)
      fakray(ntp)=2.*presneutral(ntp,1)/(rhokt*part(1,1))
cc      H2RAY(NTP)=F5*HN
      h2ray(ntp)=partryck(ntp,2)/rhokt
      if (nametryck(2).ne.'H H') then
        print*,nametryck(2), 'should be H2'
        stop 'PROBLEM in detabs!'
      endif
      heray(ntp)=presneutral(ntp,2)/rhokt

cc      do komp=1,nkomp
cc        print*,'detabs fakt(',komp,')',fakt(komp)
cc      enddo
*
      RETURN
*
C        N O T E . APART FROM VECTORS HREST AND ELS, NONE OF THE
C        TEMPERATURE- OR PRESSURE-DEPENDENT VARIABLES DEFINED ABOVE CAN
C        GENERALLY BE USED AT THE NEXT VISIT BELOW.
C        ANY SET OF FACTORS WHICH IS WANTED SHOULD BE STORED IN AN ARRAY WITH
C        DIMENSION = NT, LIKE HREST AND ELS, OR IN FAKT, WHERE THE DATA FOR
C        FURTHER USE ARE STORED IN SUBR. ABSKO.
C
C        2. WAVELENGTH-DEPENDENT FACTORS. SUMMATION.
C        CORRECTION FOR STIMULATED EMISSION
    7 continue
      EXPA=EXP(-28556.*TETA/XLA(JP))
   11 STIM=1.-EXPA
      LAMBDA3=(XLA(JP)/911.27)**3
C
C        ABSORPTION
      SUMABS=0.
C        H I
      DO 12 KOMP=2,16
        SUMABS=SUMABS+AB(KOMP)
   12 CONTINUE
      sumabs=sumabs+ab(18)
      SUMABS=(SUMABS+HREST(NTP))*XLA3(JP)
      PROV(2)=SUMABS
C        H-
      HMIN=AB(1)+AB(19)/STIM
      SUMABS=SUMABS+HMIN
      PROV(1)=HMIN
C Fe I bf     NEW: OP data from DK 98-08-23 revised later. Still needs revision
C   (smoothing resonance and not remove them) BPz 19/09-2007
      SUMABS=SUMABS+AB(17)
      PROV(3)=AB(17)
c stimulated emission already included in table in jonabs.dat for negative ions
c He-
      AB(25)=AB(25)/STIM
c C-
      AB(30)=AB(30)/STIM
c N-
      AB(33)=AB(33)/STIM
c O-
      AB(36)=AB(36)/STIM
c CO-
      AB(37)=AB(37)/stim
c H2O-
      AB(38)=AB(38)/stim
c similar also for CH, OH:
      AB(48)=AB(48)/stim
      AB(49)=AB(49)/stim
c He I ff
      AB(24)=AB(24)*LAMBDA3
c C I ff
      AB(28)=AB(28)*LAMBDA3
c C II ff
      AB(29)=AB(29)*LAMBDA3
c Mg I ff
      AB(50)=AB(50)*LAMBDA3
c Si I ff
      AB(51)=AB(51)*LAMBDA3
c Me I ff (the remaining metals)
      AB(52)=AB(52)*LAMBDA3
C
      DO 13 KOMP=20,NKOMP
        SUMABS=SUMABS+AB(KOMP)
        PROV(KOMP-16)=AB(KOMP)
   13 CONTINUE

***********************************
***      if (xla(j).gt.1100.and.xla(j).lt.2000..and.ab(20).gt.0.e0) then
***        write(100,*) xla(jp),T(ntp),ab(20),'Doyle H+H'
***      endif
***********************************
C
C        HERE FURTHER ABSORPTION MECHANISMS, GIVEN IN TABLES OR BY
C        ANALYTICAL EXPRESSIONS, MAY BE ADDED.
*
* from old detabs (C-stars) H2-H2 and H2-He pressure induced opacity
* 16/01-1996: Aleksandra Borysow me signale que stim deja inclu dans CIA.
      OMEGA=1./XLA(JP)*1.E+8
      if (borysow) then
cc        call h2borysowopac(omega,t(ntp),propac)
        call CIAh2h2(omega,t(ntp),propac)
      else
        CALL H2OPAC(OMEGA,T(NTP),PROPAC)
      endif
      H2PRES=PROPAC*PHTVA(NTP)/stim
      PROV(NPROVA-3)=H2PRES
      if (borysow) then
cc        call heborysowopac(omega,t(ntp),propac)
        call CIAh2he(omega,t(ntp),propac)
      else
        CALL HEOPAC(OMEGA,T(NTP),PROPAC)
      endif
      HEPRES=PROPAC*PHEL(NTP)/stim
      PROV(NPROVA-2)=HEPRES
      if(borysow) then
        call CIAh2h(omega,t(ntp),propac)
      else
        stop '1 in detabs'
      endif
      h2hpres=propac*ph2h(ntp)/stim
      prov(nprova-1)=h2hpres
      if(borysow) then
        call CIAhhe(omega,t(ntp),propac)
      else
        stop '2 in detabs'
      endif
      hhepres=propac*phhe(ntp)/stim
      prov(nprova)=hhepres
*
      SUMABS=SUMABS+H2PRES+HEPRES+h2hpres+hhepres
      SUMABS=SUMABS*STIM
C
C        SCATTERING
      XRAY=AMAX1(XLA(JP),1026.)
      XRAY2=1./(XRAY*XRAY)
c Changed by BPz 08/10-2007 to stop where Paul BArklem's Hlinop.f starts.
c He accounts for Rayleigh scattering in the far red wings out to that cut
c (but it is added into the pure absorption coefficient, as all his H I opacity).
      if (xla(jp).ge.1400.) then
        RAYH=XRAY2*XRAY2*(5.799E-13+XRAY2*(1.422E-6+XRAY2*2.784))*
     &     FAKRAY(NTP)
      else
        RAYH=0.0
      endif
*****************
* Scattering by HeI in cm**2/atom, from Bues & Wehrse, 1976, A&A 51, 461
*  introduced 5/02-2008 by BPz
*
      RAYHe=0.66520e-24*4.*(500./xla(jp))**4*heray(ntp)
*****************
* add h2 from old detabs
      RAYH2=XRAY2*XRAY2*(8.14E-13+XRAY2*(1.28E-6+XRAY2*1.61))*H2RAY(NTP)
      SUMSCA=ELS(NTP)+RAYH+RAYH2+RAYHe
      PROV(NPROV-3)=ELS(NTP)
      PROV(NPROV-2)=RAYH
      PROV(NPROV-1)=RAYH2
      PROV(NPROV)=RAYHe
***********************************
***      if (xla(j).gt.1100.and.xla(j).lt.2000.) then
***        write(100,*) xla(jp),T(ntp),sumabs,sumsca,'tot abs & scatt'
***        if (RAYH.gt.0.e0) then
***          write(100,*) xla(jp),T(ntp),RAYH,'rayleigh H '
***        endif
***        if (RAYH2.gt.0.e0) then
***          write(100,*) xla(jp),T(ntp),RAYH2,'rayleigh H2 '
***        endif
***      endif
***********************************
C
      IF(J.GT.0) goto 15
C
C        WEIGHT FOR A ROSSELAND MEAN
   14 VIKTR=EXPA/(STIM*STIM*(XLA3(JP)*1E-3)**2)
   15 CONTINUE
C
      IF(IOUTR-1)23,21,20
C
C        **** PRINT-OUT ****
   20 WRITE(IWRIT,200)XLA(JP),(ABNAME(KP),KP=1,NPROV)
  200 FORMAT('0WAVEL.=',F7.0,'    ABS       SCAT  ',36A6)
   21 DO22 KP=1,nprova
   22 PROV(KP)=PROV(KP)/SUMABS*STIM
      DO24 KP=1,NPROVS
   24 PROV(NPROVA+KP)=PROV(NPROVA+KP)/SUMSCA
      WRITE(IWRIT,201) T(NTP),sumabs,sumsca,(PROV(KP),KP=1,nprov)
  201 FORMAT(3H T=,F7.1,5X,2E11.4,36F6.4)
   23 CONTINUE

      RETURN
      END


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

#include "config.h"

subroutine main_dft_k_expand
  use salmon_global, only: method_wf_distributor
  implicit none

  if(method_wf_distributor=='single') then
     call main_dft_k_expand_single
  else if(method_wf_distributor=='slice') then
     call main_dft_k_expand_slice
  else
     stop "error in method_wf_distributor option"
  endif
end subroutine main_dft_k_expand

subroutine main_dft_k_expand_single
  use math_constants, only: pi, zi
  use structures
  use inputoutput
  use salmon_global
  use parallelization, only: nproc_id_global,nproc_group_global
  use communication, only: comm_is_root, comm_summation, comm_bcast, comm_sync_all
  use salmon_xc
  use timer
  use scf_iteration_sub
  use density_matrix, only: calc_density
  use writefield
  use salmon_pp, only: calc_nlcc
  use hartree_sub, only: hartree
  use write_sub
  use read_gs
  use code_optimization
  use initialization_sub
  use occupation
  use prep_pp_sub
  use mixing_sub
  use checkpoint_restart_sub
  use filesystem
  use hamiltonian
  use total_energy
  use initialization_dft
  implicit none
  type(s_rgrid) :: lg
  type(s_rgrid) :: mg
  type(s_parallel_info) :: info
  type(s_sendrecv_grid) :: srg, srg_scalar
  type(s_orbital) :: spsi,shpsi,sttpsi
  type(s_dft_system) :: system
  type(s_poisson) :: poisson
  type(s_stencil) :: stencil
  type(s_scalar) :: rho,rho_jm,Vh,Vpsl
  type(s_scalar),allocatable :: V_local(:),rho_s(:),Vxc(:)
  type(s_reciprocal_grid) :: fg
  type(s_pp_info) :: pp
  type(s_pp_grid) :: ppg
  type(s_pp_nlcc) :: ppn
  type(s_dft_energy) :: energy
  type(s_mixing) :: mixing
  type(s_ofile)  :: ofl
  type(s_k_expand) :: kex

  integer :: i,ix,iy,iz,ik
  integer :: Miter,nspin
  character(256) :: gdir, wdir0
  character(256),allocatable :: wdir(:)

  call timer_begin(LOG_TOTAL)
  call timer_begin(LOG_INIT_GS)

  !change theory input keyword : behave like dft(gs) calc
  theory = 'dft'
  calc_mode='GS'

  !check condition
  if(yn_restart /= 'y') stop "error: yn_restart must be y"
  if(process_allocation /= 'orbital_sequential') stop "error: process_allocation must be orbital_sequential"

  call init_dft(nproc_group_global,info,lg,mg,system,stencil,fg,poisson,srg,srg_scalar,ofl)
  allocate( rho_s(system%nspin),V_local(system%nspin),Vxc(system%nspin) )

  call initialization1_dft( system, energy, stencil, fg, poisson,  &
                            lg, mg,  &
                            info,  &
                            srg, srg_scalar,  &
                            rho, rho_jm, rho_s, Vh, V_local, Vpsl, Vxc,  &
                            spsi, shpsi, sttpsi,  &
                            pp, ppg, ppn,  &
                            ofl )

  nspin = system%nspin
  spsi%update_zwf_overlap = .false.
  mixing%num_rho_stock = 21
  call init_mixing(nspin,mg,mixing)  !maybe not necessary

  if(system%nspin /= 1) stop "error: nspin must be 1"
  if(nproc_k /= system%nk) stop "error: nproc_k must be # of k-points"
  if(mod(nstate,nproc_ob)/=0.or.mod(nelec/2,(nstate/nproc_ob))/=0) &
    stop "error: must be mod(nstate,nproc_ob)==0.and.mod(nelec/2,(nstate/nproc_ob))==0"

  ! read restart data
  call restart_gs(lg,mg,system,info,spsi,Miter,mixing=mixing)

  ! initialization for k-expand
  call init_k_expand(system%nk,kex)
  call get_print_rank_numbers(kex,info)

  !(prepare directory)
  call init_dir_out_restart(ofl)
  allocate(wdir(kex%nk))
  call generate_restart_directory_name_k_expand(kex,ofl%dir_out_restart,gdir,wdir)
  do ik=1,kex%nk
    !write(*,*) trim(wdir(ik))
     call create_directory(wdir(ik))
  enddo

  do ik=1,kex%nk
     if(kex%myrank(ik)==0) then
        wdir0 = wdir(ik)
        call write_info_bin(     wdir0,kex,system,Miter)
        call write_atomic_coor(  wdir0,kex,system)
        call write_atomic_vel(   wdir0,kex,system)
        call write_occ_bin(      wdir0,kex,system)
     endif
  enddo
  call write_rho_inout_bin(wdir0,kex,system,lg,mg,info,mixing)
  call write_wfn_bin(wdir,kex,system,spsi,lg,mg,info,mixing)

  !(log)
  if(comm_is_root(nproc_id_global)) then
     write(*,*)
     write(*,'(a)')         "  New parameters after expanding:"
     write(*,'(a, i6)')     "    natom =", kex%natom
     write(*,'(a, i6)')     "    nelec =", kex%nelec
     write(*,'(a, i6)')     "    nstate=", kex%nstate
     write(*,'(a,3i6)')     "    num_rgrid=", kex%num_rgrid(1:3)
     write(*,'(a,3f22.12)') "    al[A]    =", kex%al(1:3)*au_length_aa

     write(*,'(a)')         "    process_allocation = orbital_sequential"
     write(*,'(a, i6)')     "    nproc_k  =" , kex%nk_new
     write(*,'(a, i6)')     "    nproc_ob =" , nproc_ob * kex%nk
     write(*,'(a,3i6)')     "    nproc_rgrid =", nproc_rgrid(1)*kex%nkx, nproc_rgrid(1)*kex%nky, nproc_rgrid(2)*kex%nkz
  endif

  call timer_end(LOG_TOTAL)

contains

subroutine init_k_expand(mk,kex)
  use parallelization, only: nproc_id_global, nproc_group_global
  use communication, only: comm_is_root, comm_bcast
  use salmon_global, only: al,natom,nelec,nstate,num_rgrid
  use inputoutput, only: au_length_aa
  implicit none
  type(s_k_expand) :: kex
  integer :: nkxyz(3), ix,iy,iz,ixyz, iu1,iu2, mk, i,ik
  real(8) :: primitive_b(3)
  character(256) :: ifile_k_data

  kex%nk = mk
  allocate( kex%isupercell(3,kex%nk), kex%k_vec(3,kex%nk) )

  if(comm_is_root(nproc_id_global)) then
     write(*,*)"  Convert wavefunction from GS/k-points into supercell/gamma-point"
     write(*,*)"  assuming :"
     write(*,*)"  (1) # of k-points in GS is over 2 and that in RT is 1 (gamma only)"
     write(*,*)"  (2) k-points in GS is Monkhorst-pac (using user-defined k-points)"
     write(*,*)"  (3) spacial grid size does not change"
     write(*,*)"  (4) # of k-points in GS and # of blocks in super-cell in RT is the same"
     write(*,*)"  (5) cuboid cell"
     write(*,*)"  (6) process_allocation = orbital_sequential"
     write(*,*)"  (7) nproc_rgrid(1,2,3) --> x Nkx, x Nky, x Nkz"
     write(*,*)"  (8) nproc_k = nk in the input data file"
     write(*,*)"  (9) mod(nstate,nproc_ob)==0 and mod(nelec/2,(nstate/nproc_ob))==0"
     write(*,*)"  (10)nspin=1, periodic system, ...."
     write(*,*)

     !(read information from "info_k_expand.dat")
     iu1=91
     open(iu1,file="info_k_expand.dat",status="old")
     read(iu1,'(a)') ifile_k_data  !file name of k-point information printed by SALMON (xxx_k.data)
     read(iu1,*) kex%nkx, kex%nky, kex%nkz   ! super cell size ; must correspond to k-point

     nkxyz(1) = kex%nkx
     nkxyz(2) = kex%nky
     nkxyz(3) = kex%nkz
     if(kex%nk .ne. kex%nkx * kex%nky * kex%nkz) stop "Error the super cell size or k-points in gs"

     ixyz=0
     do ix=1,nkxyz(1)
     do iy=1,nkxyz(2)
     do iz=1,nkxyz(3)
        ixyz=ixyz+1
        kex%isupercell(1,ixyz)=ix
        kex%isupercell(2,ixyz)=iy
        kex%isupercell(3,ixyz)=iz
     enddo
     enddo
     enddo
     close(iu1)

     !(read information of k-point in GS)
     iu2=92
     open(iu2,file=trim(ifile_k_data),status="old")
     do i=1,5
        read(iu2,*)
     enddo
     do ik=1,kex%nk
        read(iu2,*) i, kex%k_vec(1:3,ik)  ! k=[-0.5:0.5], weight is assumed to 1
     enddo
     read(iu2,*)
     read(iu2,*) primitive_b(1:3)   !=2*pi/a

     write(*,*) "  k_vec [a.u.]"
     do ik=1,kex%nk
        kex%k_vec(:,ik) = kex%k_vec(:,ik) * primitive_b(:)
        write(*,*) ik, real(kex%k_vec(:,ik))
     enddo

     close(iu2)

  endif

  call comm_bcast(kex%nkx,       nproc_group_global)
  call comm_bcast(kex%nky,       nproc_group_global)
  call comm_bcast(kex%nkz,       nproc_group_global)
  call comm_bcast(kex%isupercell,nproc_group_global)
  call comm_bcast(kex%k_vec,     nproc_group_global)

  kex%natom    = natom * kex%nk
  kex%nelec    = nelec * kex%nk
  kex%nstate   = nstate* kex%nk
  kex%num_rgrid(:) = num_rgrid(:)* nkxyz(:)
  kex%al(:)    = al(:) * nkxyz(:)

end subroutine init_k_expand

subroutine get_print_rank_numbers(kex,info)
  use communication, only: comm_is_root, comm_bcast
  implicit none
  type(s_k_expand) :: kex
  type(s_parallel_info),intent(in) :: info
  integer :: icnt,nl,i1,i2,i3,i4,i5,k1,k2,k3,nkx,nky,nkz
  integer :: nproc_k, nproc_o, nproc_r(3)

   !!(before)
   !! (in subroutine init_communicator_dft in init_communicator.f90)
   ! nl=-1
   ! do i3=0,nproc_d_o(3)-1
   ! do i2=0,nproc_d_o(2)-1
   ! do i1=0,nproc_d_o(1)-1
   ! do i5=0,nproc_k-1
   ! do i4=0,nproc_ob-1
   !   nl = nl + 1
   !   info%imap(i1,i2,i3,i4,i5) = nl
   !   if (nl == myrank) then
   !     info%iaddress = [i1,i2,i3,i4,i5]
   !   end if
   ! end do
   ! end do
   ! end do
   ! end do
   ! end do

    nkx = kex%nkx
    nky = kex%nky
    nkz = kex%nkz

    nproc_k  = info%npk
    nproc_o  = info%nporbital
    nproc_r  = info%nprgrid

    !(after)
    allocate( kex%myrank(kex%nk) )
    allocate( kex%iaddress(8,kex%nk) )

    icnt=0
    nl=-1
    do k3= 1,nkz
    do i3= 0,nproc_r(3)-1
    do k2= 1,nky
    do i2= 0,nproc_r(2)-1
    do k1= 1,nkx
    do i1= 0,nproc_r(1)-1
    do i4= 0,nproc_o-1
    do i5= 0,nproc_k-1
       nl= nl + 1
       if ( info%iaddress(1)==i1 .and. &
            info%iaddress(2)==i2 .and. &
            info%iaddress(3)==i3 .and. &
            info%iaddress(4)==i4 .and. &
            info%iaddress(5)==i5  ) then
            icnt = icnt + 1
            kex%myrank(icnt) = nl
            kex%iaddress(1,icnt) = i1
            kex%iaddress(2,icnt) = k1
            kex%iaddress(3,icnt) = i2
            kex%iaddress(4,icnt) = k2
            kex%iaddress(5,icnt) = i3
            kex%iaddress(6,icnt) = k3
            kex%iaddress(7,icnt) = i4
            kex%iaddress(8,icnt) = i5
       endif
    end do
    end do
    end do
    end do
    end do
    end do
    end do
    end do

   !write(*,'(a,100i5)') "myrank  =", kex%myrank(:)

  end subroutine get_print_rank_numbers

  subroutine generate_restart_directory_name_k_expand(kex,basedir,gdir,pdir)
    implicit none
    type(s_k_expand) :: kex
    character(*),  intent(in)  :: basedir
    character(256),intent(out) :: gdir
    character(256),intent(out) :: pdir(kex%nk)
    integer :: ik, nproc_id_kex

    ! global directory
    write(gdir,'(A,I6.6,A)')   trim(basedir)

    ! process private directory for k-expand
    do ik=1,kex%nk
       nproc_id_kex = kex%myrank(ik)
       write(pdir(ik),'(A,A,I6.6,A)') trim(gdir),'rank_',nproc_id_kex,'/'
    enddo

  end subroutine generate_restart_directory_name_k_expand

  subroutine write_info_bin(odir,kex,system,iter)
    use parallelization, only: nproc_size_global
    implicit none
    type(s_k_expand) :: kex
    type(s_dft_system) :: system
    character(*)    :: odir
    character(1024) :: dir_file_out
    logical :: if_real_orbital_tmp
    integer :: iu3, iter, nprocs

    iu3 = 93
    dir_file_out = trim(odir)//"/info.bin"
    open(iu3,file=dir_file_out,form='unformatted')

    kex%nk_new = 1
    kex%no_new = system%no * kex%nk
    ! should comm  (kex%nk_new, kex%no_new)
    !iter       = 0
    nprocs     = nproc_size_global * kex%nk
    if_real_orbital_tmp = .false.

    write(iu3) kex%nk_new
    write(iu3) kex%no_new
    write(iu3) iter
    write(iu3) nprocs
    write(iu3) if_real_orbital_tmp

    write(*,*) "info_bin:", kex%nk_new, kex%no_new, iter, nprocs

    close(iu3)

  end subroutine write_info_bin

  subroutine write_atomic_coor(odir,kex,system)
    use salmon_global, only: al,natom,atom_name,kion,unit_length
    use inputoutput, only: au_length_aa
    implicit none
    type(s_k_expand) :: kex
    type(s_dft_system) :: system
    character(*)    :: odir
    character(1024) :: dir_file_out
    integer :: iu1, ia, ixyz
    real(8) :: uconv, Rion_new(3)

    if(unit_length=='AA')then ; uconv = au_length_aa
    else                      ; uconv = 1d0   !au
    endif

    iu1 = 91
    dir_file_out = trim(odir)//"/atomic_coor.txt"
    open(iu1,file=dir_file_out,status="unknown")

    do ia = 1,natom
       atom_name(ia) = adjustl(atom_name(ia))
       atom_name(ia) = "'"//trim(atom_name(ia))//"'"
    enddo
    do ixyz= 1,kex%nk
       do ia = 1,natom
          Rion_new(:) = system%Rion(:,ia) + al(:) * (kex%isupercell(:,ixyz)-1)
          write(iu1,7000) trim(atom_name(ia)), Rion_new(1:3)*uconv, kion(ia)
       enddo
    enddo
7000 format(" ",a6,"  ",3f18.10,i4)
    close(iu1)

  end subroutine write_atomic_coor

  subroutine write_atomic_vel(odir,kex,system)
    use salmon_global, only: natom
    implicit none
    type(s_k_expand) :: kex
    type(s_dft_system) :: system
    character(*)    :: odir
    character(1024) :: dir_file_out
    integer :: iu1, ia, ixyz

    iu1 = 91
    dir_file_out = trim(odir)//"/atomic_vel.txt"
    open(iu1,file=dir_file_out,status="unknown")

    do ixyz= 1,kex%nk
       do ia = 1,natom
          write(iu1,7100) system%Velocity(1:3,ia)
       enddo
    enddo
7100 format(3f18.10)
    close(iu1)

  end subroutine write_atomic_vel

  subroutine write_occ_bin(odir,kex,system)
    implicit none
    type(s_k_expand) :: kex
    type(s_dft_system) :: system
    character(*)    :: odir
    character(1024) :: dir_file_out
    integer :: iu1, io,ik, io_new
    real(8),allocatable :: rocc_new(:,:,:)

    iu1 = 91
    dir_file_out = trim(odir)//"/occupation.bin"
    open(iu1,file=dir_file_out,form='unformatted')

    allocate(rocc_new(1:kex%no_new, 1:kex%nk_new, 1:system%nspin))

    rocc_new(:,:,:) = 0d0
    io_new=0
    do io=1,system%no
    do ik=1,kex%nk
       io_new = io_new + 1
       rocc_new(io_new,1,nspin) = system%rocc(io,ik,nspin)
      !write(*,*) "rocc", io_new, rocc_new(io_new,1,nspin)
    enddo
    enddo
    write(iu1) rocc_new(1:kex%no_new,1:kex%nk_new,1:system%nspin)
    close(iu1)

  deallocate(rocc_new)

end subroutine write_occ_bin

subroutine write_rho_inout_bin(odir,kex,system,lg,mg,info,mixing)
  implicit none
  type(s_k_expand) :: kex
  type(s_dft_system) :: system
  type(s_rgrid) :: lg,mg
  type(s_parallel_info) :: info
  type(s_mixing) :: mixing
  character(*)    :: odir
  character(1024) :: dir_file_out  !,ofile_cube
  integer :: iu1,ik, num_rho_stock
  integer :: lg_is_new(3), lg_ie_new(3), ixyz, nval
  integer :: ix_add, iy_add, iz_add,iix,iiy,iiz
  real(8) :: norm
  real(8),allocatable :: rho_in_new(:,:,:,:), rho_out_new(:,:,:,:)
  real(8),allocatable :: tmp1_rho_in_new(:,:,:), tmp2_rho_in_new(:,:,:)
  real(8),allocatable :: tmp1_rho_out_new(:,:,:),tmp2_rho_out_new(:,:,:)

  lg_is_new(:) = lg%is(:)
  lg_ie_new(1) = lg%ie(1) * kex%nkx
  lg_ie_new(2) = lg%ie(2) * kex%nky
  lg_ie_new(3) = lg%ie(3) * kex%nkz

  nval = lg_ie_new(1)*lg_ie_new(2)*lg_ie_new(3)
  num_rho_stock = mixing%num_rho_stock

  allocate( rho_in_new( lg_ie_new(1),lg_ie_new(2),lg_ie_new(3),num_rho_stock+1))
  allocate( rho_out_new(lg_ie_new(1),lg_ie_new(2),lg_ie_new(3),num_rho_stock)  )

  !$omp parallel do collapse(3) private(i,ix,iy,iz)
  do i=1,num_rho_stock
  do ix=lg_is_new(1),lg_ie_new(1)
  do iy=lg_is_new(2),lg_ie_new(2)
  do iz=lg_is_new(3),lg_ie_new(3)
     rho_in_new( ix,iy,iz,i) = 0d0
     rho_out_new(ix,iy,iz,i) = 0d0
  enddo
  enddo
  enddo
  enddo

  allocate( tmp1_rho_in_new(lg_ie_new(1),lg_ie_new(2),lg_ie_new(3)) )
  allocate( tmp2_rho_in_new(lg_ie_new(1),lg_ie_new(2),lg_ie_new(3)) )
  allocate( tmp1_rho_out_new(lg_ie_new(1),lg_ie_new(2),lg_ie_new(3)) )
  allocate( tmp2_rho_out_new(lg_ie_new(1),lg_ie_new(2),lg_ie_new(3)) )

  tmp1_rho_in_new  = 0d0
  tmp2_rho_in_new  = 0d0
  tmp1_rho_out_new = 0d0
  tmp2_rho_out_new = 0d0

  do i=1,num_rho_stock+1
     do ixyz=1,kex%nk

        ix_add = lg%ie(1) * (kex%isupercell(1,ixyz)-1)
        iy_add = lg%ie(2) * (kex%isupercell(2,ixyz)-1)
        iz_add = lg%ie(3) * (kex%isupercell(3,ixyz)-1)

        !$omp parallel do collapse(2) private(ix,iy,iz,iix,iiy,iiz)
        do iz= mg%is(3),mg%ie(3)
        do iy= mg%is(2),mg%ie(2)
        do ix= mg%is(1),mg%ie(1)

           iix = ix + ix_add
           iiy = iy + iy_add
           iiz = iz + iz_add
           tmp1_rho_in_new(iix,iiy,iiz)  = mixing%rho_in(i)%f(ix,iy,iz)

           if(i.le.num_rho_stock) &
           tmp1_rho_out_new(iix,iiy,iiz) = mixing%rho_out(i)%f(ix,iy,iz)

        enddo
        enddo
        enddo

     enddo

     call comm_summation(tmp1_rho_in_new, tmp2_rho_in_new,  nval,info%icomm_r)

     norm = sum( tmp2_rho_in_new(:,:,:) )*system%hvol
     write(*,*) "norm of rho in density", i,real(norm)
     !tmp2_rho_in_new(:,:,:) = tmp2_rho_in_new(:,:,:)/norm

     rho_in_new(1:lg_ie_new(1),1:lg_ie_new(2),1:lg_ie_new(3),i) = &
            tmp2_rho_in_new(1:lg_ie_new(1),1:lg_ie_new(2),1:lg_ie_new(3))

     if(i.le.num_rho_stock) then
        call comm_summation(tmp1_rho_out_new,tmp2_rho_out_new, nval,info%icomm_r)

        norm = sum( tmp2_rho_out_new(:,:,:) )*system%hvol
        write(*,*) "norm of rho out density", i, real(norm)

        rho_out_new(1:lg_ie_new(1),1:lg_ie_new(2),1:lg_ie_new(3),i) = &
             tmp2_rho_out_new(1:lg_ie_new(1),1:lg_ie_new(2),1:lg_ie_new(3))
     endif

     !for check
     !ofile_cube="rho.cube"
     !call  write_cube(tmp2_rho_in_new,lg_ie_new(1),lg_ie_new(2),lg_ie_new(3),system%hgs,ofile_cube)

  enddo ! i

  !only print process only from here
  do ik=1,kex%nk
     if(kex%myrank(ik)==0) then

        iu1 = 91
        dir_file_out = trim(odir)//"/rho_inout.bin"
        open(iu1,file=dir_file_out,form='unformatted')
        do i=1,num_rho_stock+1
           write(iu1) rho_in_new(1:lg_ie_new(1),1:lg_ie_new(2),1:lg_ie_new(3),i)
        end do
        do i=1,num_rho_stock
           write(iu1) rho_out_new(1:lg_ie_new(1),1:lg_ie_new(2),1:lg_ie_new(3),i)
        end do

        close(iu1)
     endif
  enddo

  deallocate(rho_in_new,rho_out_new, tmp1_rho_in_new,tmp2_rho_in_new)

end subroutine write_rho_inout_bin

subroutine write_wfn_bin(odir,kex,system,spsi,lg,mg,info,mixing)
  implicit none
  type(s_k_expand) :: kex
  type(s_dft_system) :: system
  type(s_orbital) :: spsi
  type(s_rgrid) :: lg,mg
  type(s_parallel_info) :: info
  type(s_mixing)  :: mixing
  character(*)    :: odir(kex%nk)
  character(1024) :: dir_file_out    !,ofile_cube
 !real(8) :: tmp_norm(system%nk,system%no), norm_all(system%nk,system%no)
  real(8) :: scale, rshift(3), r(3)  !,norm
  integer :: ix_add, iy_add, iz_add  !,mx,my,mz
  integer :: iu,id,ip_x,ip_y,ip_z, inkx,inky,inkz, ip_o,ip_k
  integer :: im,ik,is,ix,iy,iz,iix,iiy,iiz !, io
 !real(8),allocatable :: orb_real(:,:,:)
  complex(8) :: ai,ekr
  complex(8),allocatable :: zwf_ekr(:,:,:,:)

  !!check norm -> later normalize to improbe accuracy
  !im = 1
  !is = 1
  !tmp_norm(system%nk,system%no) = 0d0
  !
  !do ik= info%ik_s,info%ik_e
  !do io= info%io_s,info%io_e
  !    tmp_norm(ik,io) = sum(abs(spsi%zwf(mg%is(1):mg%ie(1),mg%is(2):mg%ie(2),mg%is(3):mg%ie(3),is,io,ik,im))**2)
  !enddo
  !enddo
  !
  !call comm_summation(tmp_norm,norm_all,system%nk*system%no,info%icomm_r)
  !
  !do ik= info%ik_s,info%ik_e
  !do io= info%io_s,info%io_e
  !   norm_all(ik,io) = norm_all(ik,io) * system%hvol
  !   scale = 1d0/sqrt(norm_all(ik,io))
  !   write(*,'(a,2i6,f20.12)') "norm of orbital   ", ik,io, norm_all(ik,io)
  !   spsi%zwf(mg%is(1):mg%ie(1),mg%is(2):mg%ie(2),mg%is(3):mg%ie(3),is,io,ik,im)= &
  !   spsi%zwf(mg%is(1):mg%ie(1),mg%is(2):mg%ie(2),mg%is(3):mg%ie(3),is,io,ik,im)*scale
  !enddo
  !enddo
!--------------------

  ai        = ( 0d0, 1d0 )
  rshift(:) = -system%hgs(:)    !probably only if(yn_domain_parallel=='y')
  scale = 1d0/sqrt(dble(kex%nk))

  allocate( zwf_ekr(mg%is(1):mg%ie(1),mg%is(2):mg%ie(2),mg%is(3):mg%ie(3),info%io_s:info%io_e) )

  do id =1,kex%nk

     ![i1,k1,i2,k2,i3,k3,i4,i5]
     ip_x = kex%iaddress(1,id)
     inkx = kex%iaddress(2,id)
     ip_y = kex%iaddress(3,id)
     inky = kex%iaddress(4,id)
     ip_z = kex%iaddress(5,id)
     inkz = kex%iaddress(6,id)
     ip_o = kex%iaddress(7,id)
     ip_k = kex%iaddress(8,id)

     !now assuming ik_s=ik_e, im_s=im_e, nspin=1
     if(info%im_s /= info%im_e) stop "error im_s /= im_e"
     if(info%ik_s /= info%ik_e) stop "error ik_s /= ik_e"

     im = info%im_s
     ik = info%ik_s
     is = 1

     iu = 1000 + kex%myrank(id)
     dir_file_out = trim(odir(id))//"/wfn.bin"
     open(iu,file=dir_file_out,form='unformatted',access='stream')

     ix_add = (lg%ie(1)-lg%is(1)+1) * (inkx-1)
     iy_add = (lg%ie(2)-lg%is(2)+1) * (inky-1)
     iz_add = (lg%ie(3)-lg%is(3)+1) * (inkz-1)

     do iz = mg%is(3), mg%ie(3)
        iiz = iz + iz_add
        r(3) = iiz*system%hgs(3) + rshift(3)

        do iy = mg%is(2), mg%ie(2)
           iiy = iy + iy_add
           r(2) = iiy*system%hgs(2) + rshift(2)

           do ix = mg%is(1), mg%ie(1)
              iix = ix + ix_add
              r(1) = iix*system%hgs(1) + rshift(1)

              ekr = exp(ai * sum(kex%k_vec(:,ik)*r(:)) ) * scale
              zwf_ekr(ix,iy,iz,info%io_s:info%io_e) = &
                     spsi%zwf(ix,iy,iz,is,info%io_s:info%io_e,ik,im)* ekr

           enddo
        enddo
     enddo

     !write
     write(iu) zwf_ekr(mg%is(1):mg%ie(1),mg%is(2):mg%ie(2),mg%is(3):mg%ie(3),info%io_s:info%io_e)

    ! !for check
    ! if(ip_o==20) then
    !    mx=mg%ie(1)
    !    my=mg%ie(2)
    !    mz=mg%ie(3)
    !    allocate(orb_real(mx,my,mz))
    !    orb_real(1:mx,1:my,1:mz) = real(zwf_ekr(1:mx,1:my,1:mz,ip_o))
    !    ofile_cube="orb_20.cube"
    !    call  write_cube(orb_real,mx,my,mz,system%hgs,ofile_cube)
    ! endif

     close(iu)
  enddo
  if(allocated(zwf_ekr)) deallocate( zwf_ekr )

end subroutine write_wfn_bin

subroutine  write_cube(orb,mx,my,mz,hgs,ofl)
  implicit none
  integer :: mx,my,mz,fp,i,j,n,ix,iy,iz
  real(8) :: orb(mx,my,mz), hgs(3), crd(3,2)
  character(*) :: ofl

  n=2
  crd(:,1)=0d0
  crd(1,2)=mx*hgs(1)
  crd(2,2)=my*hgs(2)
  crd(3,2)=mz*hgs(3)

  fp=1
  open(fp,file=trim(ofl),status="unknown")
  write(fp,*) "distribution"
  write(fp,*) "All values here are in a.u."
  write(fp,'(i5,3f12.6)') n, 0d0, 0d0, 0d0
  write(fp,'(i5,3f12.6)') mx,hgs(1),0.d0,0.d0
  write(fp,'(i5,3f12.6)') my,0.d0,hgs(2),0.d0
  write(fp,'(i5,3f12.6)') mz,0.d0,0.d0,hgs(3)
  do i=1,n
     !ik=Kion(iatom)
     !write(fp,'(i5,4f12.6)') izatom(ik),dble(izatom(ik)),(Rion(j,iatom),j=1,3)
     write(fp,'(i5,4f12.6)') 8,dble(8),(crd(j,i),j=1,3)
  end do

  do ix=1,mx
  do iy=1,my
     write(fp,'(6(1X,E23.15E3))', advance="yes") (orb(ix,iy,iz),iz=1,mz)
  end do
  end do
  close(fp)

  return
end subroutine write_cube

end subroutine main_dft_k_expand_single