      SUBROUTINE DT_EVTFRG2(Kmode,Nfrg,Npymem,Irej)

C***********************************************************************
C Hadronization of chains in DTEVT1.                                   *
C                                                                      *
C Input:                                                               *
C   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
C         = 2   hadronization of DTUNUC-chains (id=66xxx)              *
C   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
C                        hadronized with one PYEXEC call               *
C         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
C                        with one PYEXEC call                          *
C Output:                                                              *
C   NPYMEM      number of entries in JETSET-common after hadronization *
C   IREJ        rejection flag                                         *
C                                                                      *
C This version dated 17.09.00 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION chklev , dum , ONE , parrj21 , parrj23 ,
     &                 parrj24 , parrj41 , parrj42 , pe , pt1 , pt2 ,
     &                 px , py , PYP , pz , rqlun , TINY1 , TINY10
      DOUBLE PRECISION TINY3 , ZERO
      INTEGER i , id , idchk , IDT_IPDGHA , idum , idxmor , iesss1 ,
     &        iesss2 , iesss3 , iesss4 , iesss5 , iesss6 , iesss7 ,
     &        iesss8 , iesss9 , iflg , ifrg , ih1 , ih2 , ihismo
      INTEGER ii , ij , ijoin , iniemc , ip , ipje , Irej , irej1 ,
     &        irej3 , ish , isjoin , ismor , iststg , jdaug , k1 , k2 ,
     &        kfmor
      INTEGER kk , Kmode , mo , mode , MXJOIN , naccep , nend , Nfrg ,
     &        nlines , npje , Npymem
      SAVE
      PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
      PARAMETER (ONE=1.0D0,ZERO=0.0D0)

      LOGICAL laccep

      PARAMETER (MXJOIN=300)

      INCLUDE 'inc/dtflka'
C event history
      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'

C flags for input different options
      INCLUDE 'inc/dtflg1'

C statistics
      INCLUDE 'inc/dtsta1'

C flags for diffractive interactions (DTUNUC 1.x)
      INCLUDE 'inc/dtflg3'

C nucleon-nucleon event-generator
      INCLUDE 'inc/dtmodl'

C phojet
C  model switches and parameters
      INCLUDE 'inc/pomdls'

C jetset

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

      INTEGER PYK

      DIMENSION ijoin(MXJOIN) , isjoin(MXJOIN) , ihismo(8000) ,
     &          iflg(4000)
      DATA iesss1 , iesss2 , iesss4 , iesss5 , iesss6 , iesss7 ,
     &     iesss8 , iesss9/0 , 0 , 0 , 0 , 0 , 0 , 0 , 0/

      mode = Kmode
      iststg = 7
      IF ( mode.NE.1 ) iststg = 6
      Irej = 0

      ip = 0
      ish = 0
      iniemc = 1
      nend = NHKk
      naccep = 0
      ifrg = 0
      IF ( NPOint(4).LE.NPOint(3) ) NPOint(4) = NHKk + 1
C     WRITE(6,*)' NPOINT 3,4,NEND ',NPOINT(3),NPOINT(4),NEND
C     WRITE(6,*)'ISTSTG ',ISTSTG
      DO i = NPOint(3) , nend
C sr 14.02.00: seems to be not necessary anymore, commented
C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
         laccep = .TRUE.
C pick up chains from dtevt1
         idchk = IDHkk(i)/10000
         IF ( (idchk.EQ.iststg) .AND. laccep ) THEN
            IF ( idchk.EQ.7 ) THEN
               ipje = IDHkk(i) - idchk*10000
               IF ( ipje.NE.ifrg ) THEN
                  ifrg = ipje
                  IF ( ifrg.GT.Nfrg ) GOTO 100
               END IF
            ELSE IF ( idchk.EQ.6 ) THEN
               ipje = 1
               ifrg = ifrg + 1
C              WRITE(6,*)'I, IDCHK,IFRG,NFRG'
C    *                   ,I, IDCHK,IFRG,NFRG,IDHKK(I)
               IF ( ifrg.GT.Nfrg ) THEN
                  Nfrg = -1
                  GOTO 100
               END IF
            END IF
C   statistics counter
C           IF (IDCH(I).LE.8)
C    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
C           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
C special treatment for small chains already corrected to hadrons
            IF ( IDRes(i).NE.0 ) THEN
               IF ( IDRes(i).EQ.11 ) THEN
                  id = IDXres(i)
               ELSE
                  id = IDT_IPDGHA(IDXres(i))
               END IF
               IF ( LEMcck ) THEN
                  CALL DT_EVTEMC(PHKk(1,i),PHKk(2,i),PHKk(3,i),PHKk(4,i)
     &               ,iniemc,idum,idum)
                  iniemc = 2
               END IF
               ip = ip + 1
               IF ( ip.GT.MSTu(4) ) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
               P(ip,1) = PHKk(1,i)
               P(ip,2) = PHKk(2,i)
               P(ip,3) = PHKk(3,i)
               P(ip,4) = PHKk(4,i)
               P(ip,5) = PHKk(5,i)
               K(ip,1) = 1
               K(ip,2) = id
               K(ip,3) = 0
               K(ip,4) = 0
               K(ip,5) = 0
               IHIst(2,i) = 10000*ipje + ip
               IF ( IHIst(1,i).LE.-100 ) THEN
                  ish = ish + 1
                  IF ( ish.GT.MXJOIN ) THEN
                     WRITE (6,*) 'ISH > MXJOIN !'
                     GOTO 200
                  END IF
                  isjoin(ish) = i
               END IF
               N = ip
               ihismo(ip) = i
            ELSE
               ij = 0
               DO kk = JMOhkk(1,i) , JMOhkk(2,i)
                  IF ( LEMcck ) THEN
                     CALL DT_EVTEMC(PHKk(1,kk),PHKk(2,kk),PHKk(3,kk),
     &                  PHKk(4,kk),iniemc,idum,idum)
                     CALL DT_EVTFLC(IDHkk(kk),1,iniemc,idum,idum)
                     iniemc = 2
                  END IF
                  id = IDHkk(kk)
                  IF ( id.EQ.0 ) id = 21
C                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
C                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))

C                  AMRQ   = PYMASS(ID)

C                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
C                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
C     &                (ABS(IDIFF).EQ.0)) THEN
CC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
C                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
C                     PHKK(4,KK) = PHKK(4,KK)+DELTA
C                     PTOT1      = PTOT-DELTA
C                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
C                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
C                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
C                     PHKK(5,KK) = AMRQ
C                  ENDIF
                  ip = ip + 1
                  IF ( ip.GT.MSTu(4) ) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
                  P(ip,1) = PHKk(1,kk)
                  P(ip,2) = PHKk(2,kk)
                  P(ip,3) = PHKk(3,kk)
                  P(ip,4) = PHKk(4,kk)
                  P(ip,5) = PHKk(5,kk)
                  K(ip,1) = 1
                  K(ip,2) = id
                  K(ip,3) = 0
                  K(ip,4) = 0
                  K(ip,5) = 0
                  IHIst(2,kk) = 10000*ipje + ip
                  IF ( IHIst(1,kk).LE.-100 ) THEN
                     ish = ish + 1
                     IF ( ish.GT.MXJOIN ) THEN
                        WRITE (6,*) 'ISH > MXJOIN !'
                        GOTO 200
                     END IF
                     isjoin(ish) = kk
                  END IF
                  ij = ij + 1
                  IF ( ij.GT.MXJOIN ) THEN
                     WRITE (6,*) 'IJ > MXJOIN !'
                     GOTO 200
                  END IF
                  ijoin(ij) = ip
                  ihismo(ip) = i
               END DO
               N = ip
C join the two-parton system

C           CALL PYLIST(2)
               CALL PYJOIN(ij,ijoin)

            END IF
            IDHkk(i) = 99999
         END IF
      END DO
 100  N = ip

      IF ( ip.GT.0 ) THEN

C final state parton shower
         DO npje = 1 , ipje
            IF ( (MCGene.EQ.2) .AND. (ish.GE.2) ) THEN
               IF ( (ISWmdl(8).EQ.1) .OR. (ISWmdl(8).EQ.3) ) THEN
                  DO k1 = 1 , ish
                     IF ( isjoin(k1).NE.0 ) THEN
                        i = isjoin(k1)
                        IF ( (IPAmdl(102).NE.1) .OR.
     &                       (IHIst(1,i).EQ.-100) ) THEN
                           ih1 = IHIst(2,i)/10000
                           IF ( ih1.EQ.npje ) THEN
                              ih1 = IHIst(2,i) - ih1*10000
                              DO k2 = k1 + 1 , ish
                               IF ( isjoin(k2).NE.0 ) THEN
                               ii = isjoin(k2)
                               ih2 = IHIst(2,ii)/10000
                               IF ( ih2.EQ.npje ) THEN
                               ih2 = IHIst(2,ii) - ih2*10000
                               IF ( IHIst(1,i).EQ.IHIst(1,ii) ) THEN
                               pt1 = SQRT(PHKk(1,ii)**2+PHKk(2,ii)**2)
                               pt2 = SQRT(PHKk(1,i)**2+PHKk(2,i)**2)

                               rqlun = MIN(pt1,pt2)
                               CALL PYSHOW(ih1,ih2,rqlun)

                               isjoin(k1) = 0
                               isjoin(k2) = 0
                               GOTO 105
                               END IF
                               END IF
                               END IF
                              END DO
                           END IF
                        END IF
                     END IF
 105              END DO
               END IF
            END IF
         END DO

         CALL DT_INITJS(mode)
C   j.r.12/01            Fragmentation of fused chains
         parrj21 = PARj(21)
         parrj23 = PARj(23)
         parrj24 = PARj(24)
         parrj41 = PARj(41)
         parrj42 = PARj(42)
C temporarily standard parameters j.r.5/02
C     PARJ(21)=1.08D0
C     PARJ(23)=0.2D0
C     PARJ(24)=2.D0
         PARj(41) = 0.15D0
         PARj(42) = 1.3D0
         iesss3 = iesss3 + 1
C      IF(IESSS3.LT.3)
C     *WRITE(6,*)' 3 PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)',
C     *      PARJ(21),PARJ(23),PARJ(24),PARJ(41),PARJ(42)
CC      IF(IESSS3.LT.3)
C     * WRITE(6,*)'3 PARJ(5),PARJ(19)',
C     *      PARJ(5),PARJ(19)
C hadronization

         CALL PYEXEC
C           CALL PYLIST(2)

         IF ( MSTu(24).NE.0 ) THEN
            WRITE (LOUt,*) ' JETSET-reject at event' , NEVhkk , MSTu(24)
     &                     , Kmode
C           CALL DT_EVTOUT(4)

C           CALL PYLIST(2)

            GOTO 200
         END IF

C   number of entries in LUJETS

         nlines = PYK(0,1)

         Npymem = nlines

         DO i = 1 , nlines
            iflg(i) = 0
         END DO

         DO ii = 1 , nlines

            IF ( (PYK(ii,7).EQ.1) .AND. (iflg(ii).NE.1) ) THEN

C  pick up mother resonance if possible and put it together with
C  their decay-products into the common
               idxmor = K(ii,3)
               IF ( (idxmor.GE.1) .AND. (idxmor.LE.MAXLND) ) THEN
                  kfmor = K(idxmor,2)
                  ismor = K(idxmor,1)
               ELSE
                  kfmor = 91
                  ismor = 1
               END IF
               IF ( (kfmor.NE.91) .AND. (kfmor.NE.92) .AND.
     &              (kfmor.NE.94) .AND. (ismor.EQ.11) ) THEN
                  id = K(idxmor,2)

                  mo = ihismo(PYK(idxmor,15))
                  px = PYP(idxmor,1)
                  py = PYP(idxmor,2)
                  pz = PYP(idxmor,3)
                  pe = PYP(idxmor,4)

                  CALL DT_EVTPUT(2,id,mo,0,px,py,pz,pe,0,0,0)
                  iflg(idxmor) = 1
                  mo = NHKk
                  DO jdaug = K(idxmor,4) , K(idxmor,5)

                     IF ( PYK(jdaug,7).EQ.1 ) THEN
                        id = PYK(jdaug,8)
                        px = PYP(jdaug,1)
                        py = PYP(jdaug,2)
                        pz = PYP(jdaug,3)
                        pe = PYP(jdaug,4)

                        CALL DT_EVTPUT(1,id,mo,0,px,py,pz,pe,0,0,0)
                        IF ( LEMcck ) THEN

                           px = -PYP(jdaug,1)
                           py = -PYP(jdaug,2)
                           pz = -PYP(jdaug,3)
                           pe = -PYP(jdaug,4)

                           CALL DT_EVTEMC(px,py,pz,pe,2,idum,idum)
                        END IF
                        iflg(jdaug) = 1
                     END IF
                  END DO
               ELSE
C  there was no mother resonance

                  mo = ihismo(PYK(ii,15))
                  id = PYK(ii,8)
                  px = PYP(ii,1)
                  py = PYP(ii,2)
                  pz = PYP(ii,3)
                  pe = PYP(ii,4)

                  CALL DT_EVTPUT(1,id,mo,0,px,py,pz,pe,0,0,0)
                  IF ( LEMcck ) THEN

                     px = -PYP(ii,1)
                     py = -PYP(ii,2)
                     pz = -PYP(ii,3)
                     pe = -PYP(ii,4)

                     CALL DT_EVTEMC(px,py,pz,pe,2,idum,idum)
                  END IF
               END IF
            END IF
         END DO
         IF ( LEMcck ) THEN
            chklev = TINY1
            CALL DT_EVTEMC(dum,dum,dum,chklev,-1,6,irej1)
C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
         END IF

C global energy-momentum & flavor conservation check
C*sr 16.5. this check is skipped in case of phojet-treatment
         IF ( MCGene.EQ.1 ) CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,
     &        irej3)

C update statistics-counter for diffraction
C        IF (IFLAGD.NE.0) THEN
C           ICDIFF(1) = ICDIFF(1)+1
C           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
C           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
C           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
C           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
C        ENDIF

      END IF

      RETURN

 200  Irej = 1
      END SUBROUTINE


!=======================================================================
! Generated by  : PSCAD v4.6.3.0
!
! Warning:  The content of this file is automatically generated.
!           Do not modify, as any changes made here will be lost!
!-----------------------------------------------------------------------
! Component     : Main
! Description   :
!-----------------------------------------------------------------------

!=======================================================================

      SUBROUTINE MainDyn()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 'emtstor.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's2.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'fnames.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'matlab.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Subroutine Arguments

! Electrical Node Indices
      INTEGER  NT_1(3)

! Control Signals
      REAL     RT_1(7), RT_2, RT_3, RT_4, RT_5(7)
      REAL     RT_6(7), RT_7, RT_8, RT_9
      REAL     RT_10(7), RT_11(7), RT_12(7)
      REAL     RT_13, RT_14, RT_15, RT_16, RT_17
      REAL     RT_18, RT_19, RT_20, RT_21, RT_22
      REAL     RT_23, RT_24, RT_25(12), RT_26(7)
      REAL     RT_27, RT_28, RT_29, RT_30(7)
      REAL     RT_31(7), RT_32, RT_33, RT_34
      REAL     RT_35(7), RT_36(7), RT_37(7)
      REAL     Va(3), Ia(3)

! Internal Variables
      REAL     RVD1_1, RVD1_2, RVD1_3, RVD1_4
      REAL     RVD1_5, RVD1_6, RVD1_7

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER ISTOF, IT_0                         ! Storage Indices
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Dsdyn <-> Dsout transfer index storage

      NTXFR = NTXFR + 1

      TXFR(NTXFR,1) = NSTOL
      TXFR(NTXFR,2) = NSTOI
      TXFR(NTXFR,3) = NSTOF
      TXFR(NTXFR,4) = NSTOC

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      ISTOF     = NSTOF
      NSTOF     = NSTOF + 126
      NPGB      = NPGB + 12
      INODE     = NNODE + 2
      NNODE     = NNODE + 14
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 27
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Transfers from storage arrays
!---------------------------------------

      RT_2     = STOF(ISTOF + 8)
      RT_3     = STOF(ISTOF + 9)
      RT_4     = STOF(ISTOF + 10)
      RT_7     = STOF(ISTOF + 25)
      RT_8     = STOF(ISTOF + 26)
      RT_9     = STOF(ISTOF + 27)
      RT_13    = STOF(ISTOF + 49)
      RT_14    = STOF(ISTOF + 50)
      RT_15    = STOF(ISTOF + 51)
      RT_16    = STOF(ISTOF + 52)
      RT_17    = STOF(ISTOF + 53)
      RT_18    = STOF(ISTOF + 54)
      RT_19    = STOF(ISTOF + 55)
      RT_20    = STOF(ISTOF + 56)
      RT_21    = STOF(ISTOF + 57)
      RT_22    = STOF(ISTOF + 58)
      RT_23    = STOF(ISTOF + 59)
      RT_24    = STOF(ISTOF + 60)
      RT_27    = STOF(ISTOF + 80)
      RT_28    = STOF(ISTOF + 81)
      RT_29    = STOF(ISTOF + 82)
      RT_32    = STOF(ISTOF + 97)
      RT_33    = STOF(ISTOF + 98)
      RT_34    = STOF(ISTOF + 99)

! Array (1:3) quantities...
      DO IT_0 = 1,3
         Va(IT_0) = STOF(ISTOF + 120 + IT_0)
         Ia(IT_0) = STOF(ISTOF + 123 + IT_0)
      END DO

! Array (1:7) quantities...
      DO IT_0 = 1,7
         RT_1(IT_0) = STOF(ISTOF + 0 + IT_0)
         RT_5(IT_0) = STOF(ISTOF + 10 + IT_0)
         RT_6(IT_0) = STOF(ISTOF + 17 + IT_0)
         RT_10(IT_0) = STOF(ISTOF + 27 + IT_0)
         RT_11(IT_0) = STOF(ISTOF + 34 + IT_0)
         RT_12(IT_0) = STOF(ISTOF + 41 + IT_0)
         RT_26(IT_0) = STOF(ISTOF + 72 + IT_0)
         RT_30(IT_0) = STOF(ISTOF + 82 + IT_0)
         RT_31(IT_0) = STOF(ISTOF + 89 + IT_0)
         RT_35(IT_0) = STOF(ISTOF + 99 + IT_0)
         RT_36(IT_0) = STOF(ISTOF + 106 + IT_0)
         RT_37(IT_0) = STOF(ISTOF + 113 + IT_0)
      END DO

! Array (1:12) quantities...
      DO IT_0 = 1,12
         RT_25(IT_0) = STOF(ISTOF + 60 + IT_0)
      END DO

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

! Array (1:3) quantities...
      DO IT_0 = 1,3
         NT_1(IT_0) = NODE(INODE + 9 + IT_0)
      END DO

!---------------------------------------
! Configuration of Models
!---------------------------------------

      IF ( TIMEZERO ) THEN
         FILENAME = 'Main.dta'
         CALL EMTDC_OPENFILE
         SECTION = 'DATADSD:'
         CALL EMTDC_GOTOSECTION
      ENDIF
!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 1:[source3] Three Phase Voltage Source Model 1 'Source1'
!  3-Phase source: Source1
      RVD1_1 = RTCF(NRTCF+12)
      RVD1_2 = RTCF(NRTCF+14)
      RVD1_3 = RTCF(NRTCF+13)
      CALL ESYS651_EXE(SS, (IBRCH+1), (IBRCH+2), (IBRCH+3),0,0,0, SS, NT&
     &_1(1),NT_1(2),NT_1(3), 0, RVD1_2, RVD1_1, 0.05, 1.0, 1.0, 1.0,RVD1&
     &_3, 1.0, 0.02, 0.05, 1.0, 0.02, 0.05, RVD1_4, RVD1_5, RVD1_6, RVD1&
     &_7)

! 1:[fixed_load] Fixed Load
      CALL LOAD3P1_EXE(SS, (IBRCH+7), (IBRCH+8), (IBRCH+9), (IBRCH+10), &
     &(IBRCH+11), (IBRCH+12))

! 1:[fixed_load] Fixed Load
      CALL LOAD3P1_EXE(SS, (IBRCH+16), (IBRCH+17), (IBRCH+18), (IBRCH+13&
     &), (IBRCH+14), (IBRCH+15))

!---------------------------------------
! Feedbacks and transfers to storage
!---------------------------------------

      STOF(ISTOF + 8) = RT_2
      STOF(ISTOF + 9) = RT_3
      STOF(ISTOF + 10) = RT_4
      STOF(ISTOF + 25) = RT_7
      STOF(ISTOF + 26) = RT_8
      STOF(ISTOF + 27) = RT_9
      STOF(ISTOF + 49) = RT_13
      STOF(ISTOF + 50) = RT_14
      STOF(ISTOF + 51) = RT_15
      STOF(ISTOF + 52) = RT_16
      STOF(ISTOF + 53) = RT_17
      STOF(ISTOF + 54) = RT_18
      STOF(ISTOF + 55) = RT_19
      STOF(ISTOF + 56) = RT_20
      STOF(ISTOF + 57) = RT_21
      STOF(ISTOF + 58) = RT_22
      STOF(ISTOF + 59) = RT_23
      STOF(ISTOF + 60) = RT_24
      STOF(ISTOF + 80) = RT_27
      STOF(ISTOF + 81) = RT_28
      STOF(ISTOF + 82) = RT_29
      STOF(ISTOF + 97) = RT_32
      STOF(ISTOF + 98) = RT_33
      STOF(ISTOF + 99) = RT_34

! Array (1:3) quantities...
      DO IT_0 = 1,3
         STOF(ISTOF + 120 + IT_0) = Va(IT_0)
         STOF(ISTOF + 123 + IT_0) = Ia(IT_0)
      END DO

! Array (1:7) quantities...
      DO IT_0 = 1,7
         STOF(ISTOF + 0 + IT_0) = RT_1(IT_0)
         STOF(ISTOF + 10 + IT_0) = RT_5(IT_0)
         STOF(ISTOF + 17 + IT_0) = RT_6(IT_0)
         STOF(ISTOF + 27 + IT_0) = RT_10(IT_0)
         STOF(ISTOF + 34 + IT_0) = RT_11(IT_0)
         STOF(ISTOF + 41 + IT_0) = RT_12(IT_0)
         STOF(ISTOF + 72 + IT_0) = RT_26(IT_0)
         STOF(ISTOF + 82 + IT_0) = RT_30(IT_0)
         STOF(ISTOF + 89 + IT_0) = RT_31(IT_0)
         STOF(ISTOF + 99 + IT_0) = RT_35(IT_0)
         STOF(ISTOF + 106 + IT_0) = RT_36(IT_0)
         STOF(ISTOF + 113 + IT_0) = RT_37(IT_0)
      END DO

! Array (1:12) quantities...
      DO IT_0 = 1,12
         STOF(ISTOF + 60 + IT_0) = RT_25(IT_0)
      END DO

!---------------------------------------
! Transfer to Exports
!---------------------------------------

!---------------------------------------
! Close Model Data read
!---------------------------------------

      IF ( TIMEZERO ) CALL EMTDC_CLOSEFILE
      RETURN
      END

!=======================================================================

      SUBROUTINE MainOut()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 'emtstor.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's2.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'fnames.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'matlab.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

      REAL    EMTDC_VVDC    !
!     SUBR    FTN180        ! FFT Calculation

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Electrical Node Indices
      INTEGER  NT_1(3)

! Control Signals
      REAL     RT_1(7), RT_2, RT_3, RT_4, RT_5(7)
      REAL     RT_6(7), RT_7, RT_8, RT_9
      REAL     RT_10(7), RT_11(7), RT_12(7)
      REAL     RT_13, RT_14, RT_15, RT_16, RT_17
      REAL     RT_18, RT_19, RT_20, RT_21, RT_22
      REAL     RT_23, RT_24, RT_25(12), RT_26(7)
      REAL     RT_27, RT_28, RT_29, RT_30(7)
      REAL     RT_31(7), RT_32, RT_33, RT_34
      REAL     RT_35(7), RT_36(7), RT_37(7)
      REAL     Va(3), Ia(3)

! Internal Variables
      INTEGER  IVD1_1

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER ISTOL, ISTOI, ISTOF, ISTOC, IT_0    ! Storage Indices
      INTEGER IPGB                                ! Control/Monitoring
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Dsdyn <-> Dsout transfer index storage

      NTXFR = NTXFR + 1

      ISTOL = TXFR(NTXFR,1)
      ISTOI = TXFR(NTXFR,2)
      ISTOF = TXFR(NTXFR,3)
      ISTOC = TXFR(NTXFR,4)

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      IPGB      = NPGB
      NPGB      = NPGB + 12
      INODE     = NNODE + 2
      NNODE     = NNODE + 14
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 27
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Transfers from storage arrays
!---------------------------------------

      RT_2     = STOF(ISTOF + 8)
      RT_3     = STOF(ISTOF + 9)
      RT_4     = STOF(ISTOF + 10)
      RT_7     = STOF(ISTOF + 25)
      RT_8     = STOF(ISTOF + 26)
      RT_9     = STOF(ISTOF + 27)
      RT_13    = STOF(ISTOF + 49)
      RT_14    = STOF(ISTOF + 50)
      RT_15    = STOF(ISTOF + 51)
      RT_16    = STOF(ISTOF + 52)
      RT_17    = STOF(ISTOF + 53)
      RT_18    = STOF(ISTOF + 54)
      RT_19    = STOF(ISTOF + 55)
      RT_20    = STOF(ISTOF + 56)
      RT_21    = STOF(ISTOF + 57)
      RT_22    = STOF(ISTOF + 58)
      RT_23    = STOF(ISTOF + 59)
      RT_24    = STOF(ISTOF + 60)
      RT_27    = STOF(ISTOF + 80)
      RT_28    = STOF(ISTOF + 81)
      RT_29    = STOF(ISTOF + 82)
      RT_32    = STOF(ISTOF + 97)
      RT_33    = STOF(ISTOF + 98)
      RT_34    = STOF(ISTOF + 99)

! Array (1:3) quantities...
      DO IT_0 = 1,3
         Va(IT_0) = STOF(ISTOF + 120 + IT_0)
         Ia(IT_0) = STOF(ISTOF + 123 + IT_0)
      END DO

! Array (1:7) quantities...
      DO IT_0 = 1,7
         RT_1(IT_0) = STOF(ISTOF + 0 + IT_0)
         RT_5(IT_0) = STOF(ISTOF + 10 + IT_0)
         RT_6(IT_0) = STOF(ISTOF + 17 + IT_0)
         RT_10(IT_0) = STOF(ISTOF + 27 + IT_0)
         RT_11(IT_0) = STOF(ISTOF + 34 + IT_0)
         RT_12(IT_0) = STOF(ISTOF + 41 + IT_0)
         RT_26(IT_0) = STOF(ISTOF + 72 + IT_0)
         RT_30(IT_0) = STOF(ISTOF + 82 + IT_0)
         RT_31(IT_0) = STOF(ISTOF + 89 + IT_0)
         RT_35(IT_0) = STOF(ISTOF + 99 + IT_0)
         RT_36(IT_0) = STOF(ISTOF + 106 + IT_0)
         RT_37(IT_0) = STOF(ISTOF + 113 + IT_0)
      END DO

! Array (1:12) quantities...
      DO IT_0 = 1,12
         RT_25(IT_0) = STOF(ISTOF + 60 + IT_0)
      END DO

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

! Array (1:3) quantities...
      DO IT_0 = 1,3
         NT_1(IT_0) = NODE(INODE + 9 + IT_0)
      END DO

!---------------------------------------
! Configuration of Models
!---------------------------------------

      IF ( TIMEZERO ) THEN
         FILENAME = 'Main.dta'
         CALL EMTDC_OPENFILE
         SECTION = 'DATADSO:'
         CALL EMTDC_GOTOSECTION
      ENDIF
!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 10:[multimeter] Multimeter
      IVD1_1 = NRTCF
      NRTCF  = NRTCF + 5
      Ia(1) = ( CBR((IBRCH+4), SS))
      Ia(2) = ( CBR((IBRCH+5), SS))
      Ia(3) = ( CBR((IBRCH+6), SS))
      Va(1) = EMTDC_VVDC(SS, NT_1(1), 0)
      Va(2) = EMTDC_VVDC(SS, NT_1(2), 0)
      Va(3) = EMTDC_VVDC(SS, NT_1(3), 0)

! 20:[datatap] Scalar/Array Tap
      RT_2 = Va(1)

! 30:[datatap] Scalar/Array Tap
      RT_3 = Va(2)

! 40:[datatap] Scalar/Array Tap
      RT_4 = Va(3)

! 50:[datatap] Scalar/Array Tap
      RT_27 = Ia(1)

! 60:[datatap] Scalar/Array Tap
      RT_28 = Ia(2)

! 70:[datatap] Scalar/Array Tap
      RT_29 = Ia(3)

! 80:[fft] On-Line Frequency Scanner
      IVD1_1=0
      CALL FTN180(0,1,7,1,60.0,60.0,RT_2,IVD1_1,RT_11,RT_5,RT_7)
      CALL FTN180(0,1,7,1,60.0,60.0,RT_3,IVD1_1,RT_10,RT_1,RT_9)
      CALL FTN180(0,1,7,1,60.0,60.0,RT_4,IVD1_1,RT_12,RT_6,RT_8)
!

! 90:[datatap] Scalar/Array Tap
      RT_16 = RT_1(1)

! 100:[datatap] Scalar/Array Tap
      RT_14 = RT_6(1)

! 110:[fft] On-Line Frequency Scanner
      IVD1_1=0
      CALL FTN180(0,1,7,1,60.0,60.0,RT_27,IVD1_1,RT_36,RT_30,RT_32)
      CALL FTN180(0,1,7,1,60.0,60.0,RT_28,IVD1_1,RT_35,RT_26,RT_34)
      CALL FTN180(0,1,7,1,60.0,60.0,RT_29,IVD1_1,RT_37,RT_31,RT_33)
!

! 120:[datatap] Scalar/Array Tap
      RT_22 = RT_26(1)

! 130:[datatap] Scalar/Array Tap
      RT_24 = RT_31(1)

! 140:[datatap] Scalar/Array Tap
      RT_13 = RT_11(1)

! 150:[datatap] Scalar/Array Tap
      RT_15 = RT_10(1)

! 160:[datatap] Scalar/Array Tap
      RT_17 = RT_12(1)

! 170:[datatap] Scalar/Array Tap
      RT_18 = RT_5(1)

! 180:[datatap] Scalar/Array Tap
      RT_19 = RT_36(1)

! 190:[datatap] Scalar/Array Tap
      RT_21 = RT_35(1)

! 200:[datatap] Scalar/Array Tap
      RT_23 = RT_37(1)

! 210:[datatap] Scalar/Array Tap
      RT_20 = RT_30(1)

! 220:[datamerge] Merges data signals into an array
      RT_25(1) = RT_13
      RT_25(2) = RT_14
      RT_25(3) = RT_15
      RT_25(4) = RT_16
      RT_25(5) = RT_17
      RT_25(6) = RT_18
      RT_25(7) = RT_19
      RT_25(8) = RT_20
      RT_25(9) = RT_21
      RT_25(10) = RT_22
      RT_25(11) = RT_23
      RT_25(12) = RT_24

! 230:[pgb] Output Channel 'Fasores'

      DO IVD1_1 = 1, 12
         PGB(IPGB+1+IVD1_1-1) = RT_25(IVD1_1)
      ENDDO

!---------------------------------------
! Feedbacks and transfers to storage
!---------------------------------------

      STOF(ISTOF + 8) = RT_2
      STOF(ISTOF + 9) = RT_3
      STOF(ISTOF + 10) = RT_4
      STOF(ISTOF + 25) = RT_7
      STOF(ISTOF + 26) = RT_8
      STOF(ISTOF + 27) = RT_9
      STOF(ISTOF + 49) = RT_13
      STOF(ISTOF + 50) = RT_14
      STOF(ISTOF + 51) = RT_15
      STOF(ISTOF + 52) = RT_16
      STOF(ISTOF + 53) = RT_17
      STOF(ISTOF + 54) = RT_18
      STOF(ISTOF + 55) = RT_19
      STOF(ISTOF + 56) = RT_20
      STOF(ISTOF + 57) = RT_21
      STOF(ISTOF + 58) = RT_22
      STOF(ISTOF + 59) = RT_23
      STOF(ISTOF + 60) = RT_24
      STOF(ISTOF + 80) = RT_27
      STOF(ISTOF + 81) = RT_28
      STOF(ISTOF + 82) = RT_29
      STOF(ISTOF + 97) = RT_32
      STOF(ISTOF + 98) = RT_33
      STOF(ISTOF + 99) = RT_34

! Array (1:3) quantities...
      DO IT_0 = 1,3
         STOF(ISTOF + 120 + IT_0) = Va(IT_0)
         STOF(ISTOF + 123 + IT_0) = Ia(IT_0)
      END DO

! Array (1:7) quantities...
      DO IT_0 = 1,7
         STOF(ISTOF + 0 + IT_0) = RT_1(IT_0)
         STOF(ISTOF + 10 + IT_0) = RT_5(IT_0)
         STOF(ISTOF + 17 + IT_0) = RT_6(IT_0)
         STOF(ISTOF + 27 + IT_0) = RT_10(IT_0)
         STOF(ISTOF + 34 + IT_0) = RT_11(IT_0)
         STOF(ISTOF + 41 + IT_0) = RT_12(IT_0)
         STOF(ISTOF + 72 + IT_0) = RT_26(IT_0)
         STOF(ISTOF + 82 + IT_0) = RT_30(IT_0)
         STOF(ISTOF + 89 + IT_0) = RT_31(IT_0)
         STOF(ISTOF + 99 + IT_0) = RT_35(IT_0)
         STOF(ISTOF + 106 + IT_0) = RT_36(IT_0)
         STOF(ISTOF + 113 + IT_0) = RT_37(IT_0)
      END DO

! Array (1:12) quantities...
      DO IT_0 = 1,12
         STOF(ISTOF + 60 + IT_0) = RT_25(IT_0)
      END DO

!---------------------------------------
! Close Model Data read
!---------------------------------------

      IF ( TIMEZERO ) CALL EMTDC_CLOSEFILE
      RETURN
      END

!=======================================================================

      SUBROUTINE MainDyn_Begin()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Subroutine Arguments

! Electrical Node Indices

! Control Signals

! Internal Variables
      REAL     RVD1_1, RVD1_2

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER IT_0                                ! Storage Indices
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      INODE     = NNODE + 2
      NNODE     = NNODE + 14
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 27
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 1:[source3] Three Phase Voltage Source Model 1 'Source1'
      CALL COMPONENT_ID(ICALL_NO,1172838013)
      RVD1_1 = 1.0
      RVD1_2 = 0.1
      CALL ESYS651_CFG(3,2,0,0,0,SS, (IBRCH+1), (IBRCH+2), (IBRCH+3),0,0&
     &,0, 60.0,60.0,0.0,230.0,0.0,0.0,100.0,230.0,230.0, 1.0,80.0,2.0,1.&
     &0,1.0,0.15, 1.0,80.0,RVD1_1,RVD1_2)

! 1:[fixed_load] Fixed Load
      CALL LOAD1P1_CFG(132.790562,60.0,10.0,5.0,2.0,2.0,0.0,0.0)

! 1:[fixed_load] Fixed Load
      CALL LOAD1P1_CFG(132.790562,60.0,8.0,2.0,2.0,2.0,0.0,0.0)

      RETURN
      END

!=======================================================================

      SUBROUTINE MainOut_Begin()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Subroutine Arguments

! Electrical Node Indices
      INTEGER  NT_1(3)

! Control Signals

! Internal Variables
      INTEGER  IVD1_1

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER IT_0                                ! Storage Indices
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      INODE     = NNODE + 2
      NNODE     = NNODE + 14
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 27
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

! Array (1:3) quantities...
      DO IT_0 = 1,3
         NT_1(IT_0) = NODE(INODE + 9 + IT_0)
      END DO

!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 10:[multimeter] Multimeter
      IVD1_1 = NRTCF
      NRTCF  = NRTCF + 5

! 20:[datatap] Scalar/Array Tap

! 30:[datatap] Scalar/Array Tap

! 40:[datatap] Scalar/Array Tap

! 50:[datatap] Scalar/Array Tap

! 60:[datatap] Scalar/Array Tap

! 70:[datatap] Scalar/Array Tap

! 80:[fft] On-Line Frequency Scanner

! 90:[datatap] Scalar/Array Tap

! 100:[datatap] Scalar/Array Tap

! 110:[fft] On-Line Frequency Scanner

! 120:[datatap] Scalar/Array Tap

! 130:[datatap] Scalar/Array Tap

! 140:[datatap] Scalar/Array Tap

! 150:[datatap] Scalar/Array Tap

! 160:[datatap] Scalar/Array Tap

! 170:[datatap] Scalar/Array Tap

! 180:[datatap] Scalar/Array Tap

! 190:[datatap] Scalar/Array Tap

! 200:[datatap] Scalar/Array Tap

! 210:[datatap] Scalar/Array Tap

! 220:[datamerge] Merges data signals into an array

! 230:[pgb] Output Channel 'Fasores'

      RETURN
      END


C--------------------------------
      BLOCK DATA
C--------------------------------
      common /ccoeff/ coeff
      character coeff*4
      COMMON /A11/GAMMA (6)
C  OUTPUT OF NUMERICAL MAPS (SEE SUBROUTINE VERCY)
      COMMON / ALPHA / IMON(12), ITRAN(2), IRCVR(2), LBMAP(2), MODE(13),
     A MODER(13), ITLAT, ITLONG, IRLAT, IRLONG, IRLATU, IRLONGU, NYEAR
      CHARACTER IMON*3, NYEAR*5, ITRAN*10, IRCVR*10, LBMAP*10, ITLAT*1,
     A ITLONG*1, IRLAT*1, IRLONG*1, IRLATU*1, IRLONGU*1, MODE*2, MODER*2
C  NOISE VALUES, SUBRS ANOIS1 AND GENOIS.
      COMMON/ANOIS/ATNU,ATNY,CC,TM,RCNSE,DU,DL,SIGM,SxGU,SxGL,KJ,JK
C CONSTANTS,SET BELOW.
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      COMMON / CONTRL / IELECT(3), KTOUT(12), MONTHS(12), SUNSP(12),
     A IANTOU, ICARD, INTEG, IRED, ISOUT, ISPROC, ISSN, ITYPE, JDASH,
     B JFREQ, JLONG, KCARD, KRUN, MAPIN, MAXNAM, MONOLD, MOREM, MORES,
     C NUMNAM, NUPROC, MAXMET, MSPEC, M100
C WEIGHTS AND ABSCISSCAE FOR 40 POINT GUASSIAN SET BELOW.
      COMMON / DATR / WT(20), XT(20), NT, NPL, XNPL, TWDIV
C GENERAL GEOGRAPHIC VARIABLES, SEE SUBR GEOM AND HFMUFES.
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON /FONE/ANEW(3),BNEW(3),ACHI(2),BCHI(2)
      COMMON / OUTLAB / LABEL(11), LAYTYP(5), IEAST, INORTH, ISOUTH,
     A IWEST, LABLI, LABLJ, LABLK
      CHARACTER IEAST*1, ISOUTH*1, INORTH*1, IWEST*1, LABEL*5, LAYTYP*2,
     A LABLI*5, LABLJ*5, LABLK*5
C SPORADIC E LAYER, SEE SUBR. ESIND.
      COMMON /ES /FS (3, 5), HS (5)
C  INPUT AND OUTPUT FILE NUMBERS
      COMMON / FILES / LUI, LUO, LU2, LU5, LU6, LU15, LU16, LU20, LU25,
     A LU26, LU35
C FREQUENCY COMPLEMENT,SEE SUBR. HFMUFES.
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
C GEOGRAPHIC VARIABLES AT SAMPLE AREAS,SEE GEOM,TIMVAR,MAGVAR AND   LUFFY.
      COMMON /GEOG /GYZ (5), RAT (5), GMDIP (5), CLCK (5), ABIY (5), ART
     1IC (5), SIGPAT (5), EPSPAT (5)
      COMMON/INFORM/INFO,IHSHR,IHLNG
      COMMON / ION / IHRE, IHRO, IHRS, LUFP, METHOD, NOISE, NPSL
      COMMON/LOSX/ANDVX(45,3),ADVX(45,3),AOFX(45,3),ARFX(45,3),GRLOSX(45
     A ,3),TGAINX(45,3),TLSKM(45,3),EFFlp(45),IAFTXR(3)
C  LONG PATH PARAMETERS,SEE SUBR LNGPAT.
      COMMON/LPATH/ GCDLNG,TXRGML(45,2),DELOPT,GMIN,YMIN,LTXRGM(2)
C  PROGRAM VERSION NUMBER, PROGRAM CONTROL VARIABLES
      COMMON / METSET / ITRUN, ITOUT, JTRUN(40), JTOUT(40)
C  F2 LAYER PARAMETERS (SEE SUBROUTINE F2VAR)
      COMMON / MFAC / F2M3(5),HPF2(5),ZENANG(5),ZENMAX(5),IEDP,FSECV(3)
      COMMON /MODES/GHOP, DELMOD(6,3),HPMOD(6,3),HTMOD(6,3),FVMOD(6,3),
     1 ITMOD (6, 3), AFMOD (6, 3)
C  CIRCUIT MUFS
      COMMON/MUFS/EMUF(24),F1MUF(24),F2MUF(24),ESMUF(24),ALLMUF(24)
     1,FOT(24),XLUF(24),HPF(24),ANGMUF(24),MODMUF,SIGL(4),SIGU(4),DELMU
     2F(4),HPMUF(4),HTMUF(4),FVMUF(4),AFMUF(4),NHOPMF(4),YFOT(4),YHPF(4)
     3 ,YMUF(4)
C  INPUT/OUTPUT CONTROL PARAMETERS
      COMMON / NAMEX / NAMES(100), INPUT
      CHARACTER NAMES*10,INPUT*85
      COMMON / OUTFMT / KLINE(26)
      CHARACTER KLINE*6
C  PARAMETERS FOR LINE PRINTER PLOTS
      COMMON / OUTGH / PLOTI(24), PLOTJ(24), PLOTK(24), XOUT(13), NPLOTS
C  LAT AND LONG DIRECTION INDICATORS, LINE NUMBER AND MAXIMUM LINES
      COMMON / OUTPRT / LINBOT(26), LINBD(14), LINTOP(15), LINTP(14),
     A GRPTYP, JOUT, LINBYP, LINES, LINMAX, LINTYP, LPAGES, NLINE
C  PREDICTED CRITICAL FREQUENCY MULTIPLIERS
      COMMON / PSCA / PSC(4), PSCB(4), IPSC
C OBLIQUE FREQUENCIES,SEE BELOW AND SUBR. GENION
      COMMON/RAYS/ANG(40),IFOB(40,30,5),NANG
      COMMON/REFLX/DELFX(45,3),HPFLX(45,3),HTFLX(45,3),GDFLX(45,3),FVFLX
     A (45,3),DSKPKM(3),DELSKP(3),HPSKP(3),HTSKP(3),DMAXKM(3),FVSKP(3)
     B ,ISKP(3),IMODE(45,3),AFFLX(45,3),DELPEN(3,5),GML(45,3),FHP(45,3)
C GEOGRAPHIC AND IONSPHERIC DATA AT SAMPLE AREAS,SEE GEOM AND GENION.
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON/SIGD/ DSL,ASM,DSU,AGLAT,DSLF,ASMF,DSUF,ACAV,FEAV,AFE,BFE
     A ,HNU,HTLOSS,XNUZ,XVE
C LATITUDES OF SUBSOLAR POINTS AND MONTH,SEE BELOW AND SUBR. HFMUFES
      COMMON / SSP / SUN(2,12), MONTH
C TIME VARIABLES, SEE HFMUFES.
      COMMON / TIME / IT, GMT, UTIME(24), GMTR, XLMT(24), ITIM, JTX
C AURORAL LOSS, POWER AND NOISE DATA, SEE SYSSY, HFMUFES AND RELBIL.
      COMMON /TON /ADJ, ADS, GNOS, GOT, REL, SL, SLS
     1, SPR, SU, SUS, XNOISE, ZNOISE, NF
C  LONG TERM NOISE DATA
      COMMON / TWO / F2D(16,6,6), P(29,16,8), ABP(2,9), DUD(5,12,5),
     A FAM(14,12), SYS(9,16,6), PERR(9,4,6)
C  LOSSES ETC. FOR MODES.  SEE SUBR. REGMOD. SEE ALSO COMMON/ZON/.
      COMMON / allMODE /ABPS(20),CREL(20),FLDST(20),HN(20),HP(20),
     1PROB(20),RELY(20),RGAIN(20),SIGPOW(20),SN(20),
     2SPRO(20),TGAIN(20),TIMED(20),TLOSS(20),B(20),FSLOS(20),
     3grlos(20),adv(20),obf(20),
     CNMODE(20),TLLOW(20),TLHGH(20),EFF(20),NREL,NMMOD
C ALL MODES OUTPUT ARRAYS
CPC      COMMON/INDICEZ/ISP,ISZ,IFQN,IUR,NMS(11,24,4,2)
CPC      COMMON/SPALMOUT/RNZ(11,24,4,2),DUZ(11,24,4,2),DLZ(11,24,4,2),
CPC     -ZTL(20,11,24,4,2),BBZ(20,11,24,4,2), ZLO(20,11,24,4,2),
CPC     -ZHG(20,11,24,4,2)
CPC      COMMON/LPALMOT2/zACAV(24,4,2),zASM(24,4,2),zDSL(24,4,2),
CPC     +zDSU(24,4,2),zYMUF(4,24,4,2),zYFOT(4,24,4,2),zYHPF(4,24,4,2),
CPC     +zFVMUF(4,24,4,2),zSIGL(4,24,4,2),zSIGU(4,24,4,2)
CPC      common/lpalmcmp/imddl(45,2,11,24,4,2),igdfx(45,2,11,24,4,2),
CPC     +itlos(45,2,11,24,4,2),ihpfx(45,2,11,24,4,2),lNANG(2,11,24,4,2)
CPC      integer*2 imddl,igdfx,itlos,ihpfx,lNANG
C
C SET PREDEFINED CONSTANTS.
C
      data coeff/'CCIR'/        !  default coefficients
C     CONSTANTS
C125PC      DATA ISP,ISZ,IFQN,IUR /2,4,2*0/, INFO/0/
      DATA INFO/0/
      DATA XT      /0.0387724175,0.1160840707,0.1926975807,0.2681521850,
     1              0.3419940908,0.4137792043,0.4830758017,0.5494671251,
     2              0.6125538897,0.6719566846,0.7273182552,0.7783056514,
     3              0.8246122308,0.8659595032,0.9020988070,0.9328128083,
     4              0.9579168192,0.9772599500,0.9907262387,0.9982377097/
      DATA WT      /0.0775059480,0.0770398182,0.0761103619,0.0747231691,
     1              0.0728865824,0.0706116474,0.0679120458,0.0648040135,
     2              0.0613062425,0.0574397691,0.0532278470,0.0486958076,
     3              0.0438709082,0.0387821680,0.0334601953,0.0279370070,
     4              0.0222458492,0.0164210584,0.0104982845,0.0045212771/
      DATA JTRUN / 1,2,4*3,5*4,5,3*6,10*7,5*8,10*0/,
     A     JTOUT / 1,2,3,3*4,10,4*4,5,3*6,8*7,8,9,3,3*4,11,10*0/
      DATA ITRUN/0/, ITOUT/0/
      DATA RZ/6370./,PI/3.1415926/,VOFL/299.79246/, DCL/1.28/
      DATA GAMA/0.57721566/,PI2/6.283185307/,PIO2/1.570796326/
      DATA D2R/.01745329251/, R2D/57.295779513/
      DATA ANG/0., 0.5, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 8.0, 10.0, 12.0
     1,14.,16.,18.,20.,22.,24.,26.,28.,30.,32.,34.,36.,38.,40.,42.,44.
     2 ,46.,48.,50.,52.,54.,56.,60.,65.,70.,75.,80.,85.,89.99/
      DATA IMON /'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
     A 'Oct','Nov','Dec' /
      DATA NAMES / 'METHOD    ', 'MONTH     ', 'MONTHLOOP ',
     A 'SUNSPOT   ', 'CIRCUIT   ', 'SYSTEM    ', 'TIME      ',
     B 'ANTENNA   ', 'FREQUENCY ', 'LABEL     ', 'INTEGRATE ',
     C 'EXECUTE   ', 'SAMPLE    ', 'EFVAR     ', 'ESVAR     ',
     D 'EDP       ', 'AUXIN     ', 'AUXOUT    ', 'ANTOUT    ',
     E 'OUTGRAPH  ', 'COMMENT   ', 'FREEFORM  ', 'PROCEDURE ',
     F 'END       ', 'NEXT      ', 'QUIT      ', 'FPROB     ',
     G 'TOPLINES  ', 'BOTLINES  ', 'INFORM    ',
     H 'AREA      ', 'LINEMAX   ', 'COEFFS    ', 'ZONES     ',
     H 66*'          '/
      DATA LABEL / '  ANG', ' EMUF', 'ESMUF', '  FOT', 'F1MUF', 'F2MUF',
     A '  HPF', '  LUF', ' MODE', '  MUF', '     ' /
      DATA LAYTYP /' E', 'F1', 'F2', 'ES', ' N'/
c%lc:gsp, change 1b     12 Jan 1995,                          blockdata blkdat
c%lc      fdays basis changed to hop muf, not path. Name changed accordingly.
c%lc      DATA KLINE/'MODE  ','ANGLE ','DELAY ','V HITE','F DAYS',
      DATA KLINE/'MODE  ','TANGLE','DELAY ','V HITE','MUFday',
     A           'LOSS  ','DBU   ','S DBW ','N DBW ','SNR   ',
     B           'RPWRG ','REL   ','MPROB ','S PRB ','SIG LW',
     B           'SIG UP','SNR LW','SNR UP','TGAIN ','RGAIN ',
     c           'SNRxx ','DBM   ','RANGLE','N dl  ','N du  ','      '/
c%lc. end change 1b
      DATA PSCB/1.,1.,1.,0.7/, PSC/1.,1.,1.,0.7/, IPSC/0/
      DATA SUN/-23.05,-17.31,-17.30,-7.89,-7.88,4.21,4.26,
     1 14.83, 14.84, 21.93, 21.93, 23.45, 23.15, 18.23, 18.20, 8.68, 8.5
     2 5, -2.86, -2.90, -14.16, -14.20, -21.68, -21.66, -23.45/
      DATA GCDLNG/10000./,DELOPT/3./,GMIN/3./,YMIN/.1/
      DATA ADJ/1./,ADS/1./,GNOS/1./,GOT/1./
      DATA RCNSE/-204./,REL/.01/,SL/1./,SLS/1./,SPR/.01/,SU /1./,SUS/1./
      DATA XNOISE/1./
      data noise/-4/   !  default=remote
      DATA ZNOISE/-204./, NF/1/, FLUX/1./, DMP/0.85/
      DATA ERTR/1./, PMP/10./, PWR/1./, RSN/1./, SIGTR/1./
      DATA ATNU/-204./,ATNY/-204./,CC/1./,TM/1./
      DATA DU/9./,DL/4./,SIGM/1.5/,SXGL/1./,SXGU/1./,KJ/1/,JK/1/
      DATA IELECT/0,0,0/
      DATA IHRO,IHRE,IHRS/12,24,12/, ITIM/-1/, LINES/55/
      DATA LPAGES/0/, FREL(14)/-1./
      DATA JOUT/20/, INORTH/'N'/, IEAST/'E'/, ISOUTH/'S'/, IWEST/'W'/,
     A NLINE/55/, LINMAX/55/, ITYPE/0/, JLONG/-1/
      DATA MONTH/0/, NYEAR/'     '/, SSN/0./
      DATA ICARD/0/, KCARD/0/, MOREM/0/, MORES/0/, MAPIN/-1/, MONOLD/0/,
     A INTEG/1/, IANTOU/0/, ISOUT/0/, NUPROC/0/, ISPROC/0/, ISSN/0/,
     B NUMNAM/34/, MAXNAM/100/, MAXMET/30/, IRED/1/, MSPEC/0/,M100/75/
      DATA NMMOD/1/, NREL/1/, IEDP/-1/
      DATA AMIND/3./, AMIN/.05236/
      DATA IT/1/, JFREQ/0/, JTX/1/, KM/1/, KFX/1/, KRUN/0/, LTXRGM/1,1/,
     A METHOD/-1/, LINBYP/0/, LINTYP/0/, NANG/0/, NPLOTS/0/
C
C     PRESET TO BOULDER, COLO. TO ST. LOUIS, MO. SO THAT A CIRCUIT CARD
C     IS NOT NECESSARY.
      DATA ITRAN/'BOULDER, C','OLORADO   '/,
     1     IRCVR/'ST. LOUIS,',' MISSOURI '/
      DATA TLATD/40.03/, ITLAT/'N'/, TLONGD/105.3/, ITLONG/'W'/,
     A RLATD/38.67/, IRLAT/'N'/, RLONGD/90.25/, IRLONG/'W'/, NPSL/0/
      DATA TLAT/.6986553/,TLONG/-1.837308/,RLAT/.6749188/
      DATA RLONG/-1.57516/,GCDKM/1301.1/,GCD/.204254/,BTR/1.60291/
      DATA BTRD/91.84/, BRTD/281.42/
      DATA RD/.102127,.0,.0,.0,.0/,GLAT/.862245,.0,.0,.0,.0/
      DATA CLAT/.691011,.0,.0,.0,.0/,CLONG/-1.70495,.0,.0,.0,.0/
      DATA SIGPAT/.001,.001,.001,.001,.001/,EPSPAT/4.,4.,4.,4.,4./
      DATA ALATD/39.592/,GYZ/1.358,.0,.0,.0,.0/
      DATA GMDIP/.959931,.0,.0,.0,.0/
C.....ELIMINATE D-REGION ABSORPTION ON ES ONLY
C.....PRESET FOR EFFECTIVE ELIMINATION OF LAYERS USING "KRUN" OPTION
      DATA FS/15*0./, FI/10*0.,5*0.2/, HI/5*110.,5*0.,5*300./,
     A YI/5*20.,5*0.,5*100./
      DATA LUI, LUO, LU2, LU5, LU6, LU15, LU16, LU20, LU25,
     A LU26, LU35/15,16,2,11,12,15,16,20,25,26,35/
C
C---------------------------------
C
C     PROGRAM VERSION NUMBER
C
C
CC---------------------------------

ccc      DATA VERSN /95.0512/         !  Changes external to propagation
ccc      DATA VERSN /95.0501/         !  Changes external to propagation
ccc      DATA VERSN /95.0428/         !  Fix METHOD 30 (SMOOTHING) for area calc
ccc      DATA VERSN /95.0411/         !  Changes external to propagation
ccc      DATA VERSN /95.0327/         !  Changes external to propagation
ccc      DATA VERSN /95.0314/         !  Changes external to propagation
ccc      DATA VERSN /95.0222/         !  Additional LUCAS change that was missed
ccc      DATA VERSN /95.0215/         !  changes to make DOS & UNIX same code
c                                      & allow maximum of frequency complement
ccc      DATA VERSN /95.0120/         !  LUCAS changes incorporated
ccc      DATA VERSN /95.0109/         !  Changed REDMAP for standard coeff files
ccc      DATA VERSN /95.0105/         !  Changed Man-Made Noise defaults
ccc      DATA VERSN /94.1114/         !  Changed SNR90 to SNRxx
ccc      DATA VERSN /94.1103/         !  fixed coeff error (115.2 > 11.52)
ccc      DATA VERSN /94.0902/         !  method 30 (smoothing) activated
ccc      DATA VERSN /94.0526/

C---------------------------------
C
C   VOACAP VERSION 92.0515 of   15 May 1992  is the initial interactive
C   version of VOACAP (EUIP) to be tested by VOA.
C
C---------------------------------
C
C      ADD COMMENTS ON OTHER VERSIONS
C
C---------------------------------
C
C   VOACAP VERSION 91.0821 of   21 Aug 1991   contains two significant
C   modifications since Vers. 91.0510.
C
C          1)  This is the first version to contain an interactive entry
C     of data in lieu of the older card image file format.
C          2)  The calling sequency to find OVER-THE-MUF modes was changed
C     to assure at least an over-the-muf mode for each layer.  The old call
C     sequence was (starting in the hop loop in LUFFY) LUFFY called REGMOD
C     which in turn called FDIST then INMUF before RETURNing to LUFFY with
C     up to 6 modes for each hop. In LUFFY after exiting the hop loop, if
C     no modes were found for the three hop numbers, then INMOD was called
C     which found one over-the-muf mode AND no more. In the new sequence
C xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx continue here
C
C---------------------------------
C
C   VOACAP VERSION 91.0701 of    1 JUL 1991   contains three significant
C   modifications, a cosmetic change, a clerical change, AND one puristic.
C
C          1)  It is the iniTIAL version to provide an option to smooth
C     prediction results between the Short path model AND the Long path
C     model for distances between 7000 AND 10000 kilometers.  This is
C     implemented per VOA Memo of 15 January 1991 by selecting method
C     121 in columns 23 thru 25 on the method card.  All parameters needed
C     in IONANT for this smoothing are automatically output in the binary
C     file when the all modes option is selected by placing 125 in columns
C     23 thru 25.
C          2)  The VHF test output lines have been completely eliminated.
C          3)  Subroutines LNGOUT AND OUTLNG were incomplete AND were
C     never called so they were deleted.
C          4)  This version is the first to have its version number updated
C     with each modification AND to contain a comment section, namely this,
C     which briefly describes the current changes.
C          5)  All output pages generated using this version will automati-
C     cally bear this new version number for reference. The two most signif-
C     icant digits of the version number are the year of the modification,
C     the next two significant digits are the month AND the two least sig-
C     nificant are the day.
C          6)  An option to force an all modes method (METHOD=25) for paths
C     greater than 10,000 kilometers has been added. However when this is
C     selected the short path model is used AND NOT the long path model.
C
C---------------------------------
C
      END
C--------------------------------


c **********************************************************************
c This SOFTWARE  has been authored  by an employee   or employees of the
c University  of  California, operator    of the  Los   Alamos  National
c Laboratory  under Contract No. W-7405-ENG-36  with the U.S. Department
c of  Energy.   The U.S. Government  has  rights to use,  reproduce, and
c distribute this SOFTWARE.   The  public may copy,  prepare  derivative
c works and publicly display this SOFTWARE without charge, provided that
c this  Notice  and any statement  of  authorship are  reproduced on all
c copies.  Neither the Government nor the University makes any warranty,
c express or implied, or assumes any liability or responsibility for the
c use  of this SOFTWARE.  If SOFTWARE  is modified to produce derivative
c works, such  modified SOFTWARE should be clearly  marked, so as not to
c confuse it with the version available from LANL.
c
c It is expressly forbidden to distribute this code, in whole or in part,
c either as is or modified.
c **********************************************************************

c**********************************************************************
      subroutine refine_transition(natom,nmove,nsnap,x1,x2,xsnap
     +    ,xyzneighs,nneighs,barrevev,ereverse,ityp,taxes,ietype,maxtyp
     +    ,rcut,hyperratio,irotalign,itermax,gfac,transcrit,itranscrit
     +    ,intermediate,gcrit,dvcrit,drcrit,ipr,imode,ileft,iright
     +    ,ifundc,rank_f)

      implicit real*8(a-h,o-z)

c      parameter (mxatom=10000)
      include 'parameters.h'

      dimension x1(3*natom),x2(3*natom),xsnap(3*natom*nsnap)
      dimension xyzneighs(3*natom*nneighs),barrevev(nneighs-1)
      dimension rcut(maxtyp,maxtyp),ityp(natom)
      dimension x12(3*mxatom*2)
      dimension taxes(3)
      character*180 filnam
      character*10 chri
      integer rank_f

      do j=1,3*natom            ! setup x12 for passing to descent_check
         x12(j)=x1(j)
         x12(j+3*natom)=x2(j)
      enddo

      intermediate=0
      ileft=1
      iright=nsnap

      isnap=(iright-ileft)/2+ileft
      if((ipr.ge.4).and.(rank_f.eq.0))
     +    write(6,*) 'RT: new isnap: ',ileft,isnap,iright

 200  continue                  !loop for checking new snap
      indexr=(isnap-1)*3*natom+1
      ereverseuse=0.0d0         ! don't do reverse barrier stuff as here comparing to x12
      call descent_check(natom,nmove,2,xsnap(indexr),x12,
     +    ityp,taxes,ietype,maxtyp,rcut,hyperratio,barrevev,ereverseuse
     +    ,isame,irotalign,itermax,gfac,transcrit,itranscrit,gcrit
     +    ,dvcrit,drcrit,ipr,imode,ifundc)
      if (isame.ne.0) goto 100

      if (ereverse.gt.0.0d0) then
         indexr=(isnap-1)*3*natom+1
         call descent_check(natom,nmove,nneighs,xsnap(indexr),xyzneighs
     +       ,ityp,taxes,ietype,maxtyp,rcut,hyperratio,barrevev,ereverse
     +       ,isamerev,irotalign,itermax,gfac,transcrit,itranscrit,gcrit
     +       ,dvcrit,drcrit,ipr,imode,ifundc)
         if (isamerev.gt.1) then
            if (barrevev(isamerev-1).lt.ereverse) then
               if ((ipr.ge.4).and.(rank_f.eq.0)) write(6,*)
     +             'refinetransition: intermediate min found '
     +             ,'but reverse barrier (',barrevev(isamerev-1)
     +             ,') less than ereverse=',ereverse
               isame=1
               goto 100
            endif
         endif
      endif

      if((ipr.ge.4).and.(rank_f.eq.0))
     +  write(6,*) 'refinetransition note: snap=',isnap
     +    ,' is in neither basin x1 nor x2!'
      if (ipr.ge.10) then
         filnam='snap.'//chri(isnap)//'.dat'
         call storefile(natom,xsnap(indexr),xsnap(indexr),ityp,taxes,
     +       filnam)
         filnam='snap.'//chri(isnap)//'.1'//'.dat'
         call storefile(natom,x12(1),x12(1),ityp,taxes,
     +       filnam)
         filnam='snap.'//chri(isnap)//'.2'//'.dat'
         call storefile(natom,x12(3*natom+1),x12(3*natom+1),ityp,taxes,
     +       filnam)
      endif

      intermediate=1
      do j=1,3*natom
         x2(j)=xsnap((isnap-1)*3*natom+j)
         x12(j+3*natom)=x2(j)
      enddo
      iright=isnap

 100  continue
      if (isame.eq.2) then
         if ((ipr.ge.4).and.(rank_f.eq.0))
     +     write(6,*) 'refinetransition: snap ',isnap,' is in basin 2'
         iright=isnap
      else if (isame.eq.1) then
         if ((ipr.ge.4).and.(rank_f.eq.0))
     +     write(6,*) 'refinetransition: snap ',isnap,' is in basin 1'
         ileft=isnap
      endif
      isnap=(iright-ileft)/2+ileft
      if ((ipr.ge.4).and.(rank_f.eq.0))
     +  write(6,*) 'refinetransition: new isnap: ',ileft,isnap,iright
      if (isnap.eq.ileft.or.isnap.eq.iright) return
      goto 200

      return
      end
c**********************************************************************


  subroutine initial (gsmObj, proj, output)

! ======================================================================
!
!   CEM95 written by S. G. Mashnik
!
!   Initial contains the initialization of various constants and
!   variables originally set in the main program of cem95.  This is in
!   order to shorten the program, and to remove functionality to a
!   single-purpose routine.
!
! ======================================================================
!
!    Written by A. J. Sierk,  LANL  T-2  May, 1996.
!    Modified by AJS, January-March, 1999.
!    Modified by SGM at 06/16/2000
!   "Last" change: 12-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, October, 2003.
!    Modified by K. K. Gudima, October-November, 2004.
!    Edited by AJS, January, 2005.
!    Modified by KKG, February, 2005.
!    Modified : 16-Dec-2005 by AJS, following suggestion of REP.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!    Edited by CMJ, Sept. 2016 (Added LAQGSM variables)
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, int64, real64
    use gsm_params, only: zro, one, two, thr, thousand

    implicit none
    class(GSM),           intent(inout) :: gsmObj
    class(GSMProjectile), intent(in   ) :: proj
    class(GSMOutput),     intent(inout) :: output

    integer(int32) :: i, j, j1, j2, j3, k, l
    real(real64)   :: temp, tkmax
    logical        :: log1, log2
    logical, save  :: first = .TRUE.

! ======================================================================

    real(real64) :: te1, te2, dtt, se, dtdo, d2spec, d2spe
    integer(int32) :: ntt, ntet, nt2, nt3, nti
    common /d2sdto/  te1(200), te2(200), dtt(200), &
         & se(200), dtdo(200,10), d2spec(9,10,200), &
         & d2spe(14,10,200), ntt, ntet, nt2, nt3, nti(4)
    real(real64) :: eestt, eestsq, aeqtot, aeqsq, zeqtot, zeqsq, &
         & aemin, aemax, eletot, elesq, elemin, elemax, &
         & eestrmn, eestrmx, zemin, zemax
    integer(int64) :: neq
    common /eqidat/  eestt, eestsq, aeqtot, aeqsq, zeqtot, zeqsq, &
         & aemin, aemax, eletot, elesq, elemin, elemax, &
         & eestrmn, eestrmx, zemin, zemax, neq
    real(real64) :: estart, estarsq, estrmn, estrmx, atot, atsq, &
         & ammin, ammax, eltot, elsq, elmmin, elmmax, ztot, &
         & ztsq, zmmin, zmmax, bftot, bfsq, bfmin, bfmax
    common /fisda2/  estart, estarsq, estrmn, estrmx, atot, atsq, &
         & ammin, ammax, eltot, elsq, elmmin, elmmax, ztot, &
         & ztsq, zmmin, zmmax, bftot, bfsq, bfmin, bfmax
    real(real64) :: pmul, dpmul, y, dy, emean, pmulc, dpmulc, yc, dyc, &
         & emeanc, pmulpf, dpmulpf, ypf, dypf, emeanpf, pmulsp, dpmulsp, &
         & ysp, dysp, emeansp, pmulf, dpmulf, yf, dyf, emeanf, pmcoa, &
         & dpmcoa, ycoal, dycoal, emeanco
    common /multip/ pmul(9),   dpmul(9),   y(9),   dy(9),   emean(9),  &
         & pmulc(14), dpmulc(14), yc(14), dyc(14), emeanc(14), &
         & pmulpf(6), dpmulpf(6), ypf(6), dypf(6), emeanpf(6), &
         & pmulsp(6), dpmulsp(6), ysp(6), dysp(6), emeansp(6), &
         & pmulf(6),  dpmulf(6),   yf(6),  dyf(6),  emeanf(6), &
         & pmcoa(4), dpmcoa(4), ycoal(4), dycoal(4), emeanco(4)
    integer(int32) :: nevtype
    common /nevtyp/  nevtype
    real(real64) :: epstt, epstsq, apqtot, apqsq, zpqtot, zpqsq, &
         & apmin, apmax, elptot, elpsq, elpmin, elpmax, &
         & epstrmn, epstrmx, zpmin, zpmax
    integer(int64) ::npreq
    common /predat/  epstt, epstsq, apqtot, apqsq, zpqtot, zpqsq, &
         & apmin, apmax, elptot, elpsq, elpmin, elpmax, &
         & epstrmn, epstrmx, zpmin, zpmax, npreq
    real(real64) :: speco, anco, d2speco
    common /rescoa/  speco(4,200), anco(4,20), d2speco(4,10,200)
    real(real64) :: erkt, erksq, artot, arsq, zrtot, zrsq, &
         & armin, armax, elrtot, elrsq, elrmin, elrmax, &
         & erkmn, erkmx, zrmin, zrmax
    integer(int64) :: nres
    common /resdat/  erkt, erksq, artot, arsq, zrtot, zrsq, &
         & armin, armax, elrtot, elrsq, elrmin, elrmax, &
         & erkmn, erkmx, zrmin, zrmax, nres
    real(real64) :: spef, anf, d2spef
    common /resfis/  spef(6,200), anf(6,20), d2spef(6,10,200)
    real(real64) :: spe, an
    common /resmac/  spe(14,200), an(14,20)
    real(real64) :: specsp, angsp, d2spesp
    common /respal/  specsp(6,200), angsp(6,20), d2spesp(6,10,200)
    real(real64) :: specpf, angpf, d2spepf
    common /resprf/  specpf(6,200), angpf(6,20), d2spepf(6,10,200)
    real(real64) :: spec, ang, chan, dadz
    common /result/  spec(9,200), ang(9,20), chan(218), dadz(351,151)
    real(real64) :: arttot, artsq, artmin, artmax, zrttot, zrtsq, zrtmin, &
         & zrtmax, elrttot, elrtsq, elrtmin, elrtmax
    integer(int64) :: nret
    common /retdat/  arttot, artsq, artmin, artmax, zrttot, zrtsq,  &
         & zrtmin, zrtmax, elrttot, elrtsq, elrtmin,  &
         & elrtmax, nret
    integer(int32) :: istp
    common /stopr/   istp
    real(real64) :: totke
    common /tkftot/  totke
    !   KKG 11/13/04:
    real(real64) :: dadz4
    common /result1/ dadz4(4,351,151)
    real(real64) :: rdis, dex, dpm
    common /resdis/  rdis(5,5,250), dex, dpm
    real(real64) :: opan, dth12
    common /fisopa/  opan(7,185), dth12
    real(real64) :: disnm
    common /disnmu/  disnm(6,155)

! ======================================================================

    ! Only allow one thread to set initial output data:
    !$OMP critical

    do i = 1,9
       pmul(i) = zro
       dpmul(i) = zro
       y(i) = zro
       dy(i) = zro
       emean(i) = zro
    end do

    do k = 1,200
       do j = 1,9
          spec(j,k) = zro
          if (j <= 6) then
             spef(j,k) = zro
             specpf(j,k) = zro
             specsp(j,k) = zro
          endif
          if (j <= 4) speco(j,k) = zro
          do i = 1,10
             d2spec(j,i,k) = zro
             if (j <= 4) d2speco(j,i,k) = zro
             if (j <= 6) then
                d2spef(j,i,k) = zro
                d2spepf(j,i,k) = zro
                d2spesp(j,i,k) = zro
             endif
          end do
       end do
       do j = 1,14
          spe(j,k) = zro
          do i = 1,10
             d2spe(j,i,k) = zro
          end do
       end do
    end do

    do i = 1,4
       pmcoa(i) = zro
       dpmcoa(i) = zro
       ycoal(i) = zro
       dycoal(i) = zro
       emeanco(i) = zro
       temp = output%energyBinSubStep(i)
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          print *, 'divide by zero error in initial.f90 line 311'
       end if
       nti(i) = nint((output%energyBins(i)%upperBound - &
          & output%energyBins(i)%lowerBound)/temp)
    end do
    do j = 1,10
       if (output%angleBins(j)%lowerBound < zro) then
          ntet = j - 1
          go to 10
       endif
    end do
    ntet = 10

10  do k = 1,20
       do j = 1,9
          ang(j,k) = zro
       end do
       do j = 1,14
          an(j,k) = zro
          if (j <= 6) then
             anf(j,k) = zro
             angsp(j,k) = zro
             angpf(j,k) = zro
          endif
          if (j <= 4) anco(j,k) = zro
       end do
    end do

    do k = 1,218
       chan(k) = zro
    end do

    do k = 1,151
       do j = 1,351
          dadz(j,k) = zro
          do l=1,4
             dadz4(l,j,k)=zro
          enddo
       end do
    end do

    do i=1,5
       do j=1,5
          do k=1,250
             rdis(i,j,k) = zro
          enddo
       enddo
    enddo
    dex = 10.d0
    dpm = 10.d0
    if (proj%kinEnergy > 0.7d0) dpm = 20.d0
    if (proj%kinEnergy > 1.5d0) dpm = 40.d0
    if (proj%kinEnergy > 2.5d0) dpm = 50.d0
    if (proj%kinEnergy > 1.1d0) dex = 20.d0
    do i=1,7
       do j=1,185
          opan(i,j) = zro
       enddo
    enddo
    dth12 = one

    do  i=1,6
       do  j=1,155
          disnm(i,j) = zro
       enddo
    enddo

    do i = 1,14
       pmulc(i) = zro
       dpmulc(i) = zro
       yc(i) = zro
       dyc(i) = zro
       emeanc(i) = zro
    end do

    do i = 1,6
       pmulf(i) = zro
       dpmulf(i) = zro
       yf(i) = zro
       dyf(i) = zro
       emeanf(i) = zro
       pmulpf(i) = zro
       dpmulpf(i) = zro
       ypf(i) = zro
       dypf(i) = zro
       emeanpf(i) = zro
       pmulsp(i) = zro
       dpmulsp(i) = zro
       ysp(i) = zro
       dysp(i) = zro
       emeansp(i) = zro
    end do

    tkmax = proj%kinEnergy * thousand + 30.d0
    if (proj%particleFlag == pionProjFlag) tkmax = tkmax + 110.d0
    do j = 1,199
       j1 = j - nti(1)
       j2 = j1 - nti(2)
       j3 = j2 - nti(3)
       if (j1 <= 0) then
          te1(j) = output%energyBins(1)%lowerBound + &
               & output%energyBinSubStep(1)*dble(j-1)
          te2(j) = te1(j) + output%energyBinSubStep(1)
       elseif (j2 <= 0) then
          te1(j) = output%energyBins(2)%lowerBound + &
               & output%energyBinSubStep(2)*dble(j1-1)
          te2(j) = te1(j) + output%energyBinSubStep(2)
       elseif (j3 <= 0) then
          te1(j) = output%energyBins(3)%lowerBound + &
               & output%energyBinSubStep(3)*dble(j2-1)
          te2(j) = te1(j) + output%energyBinSubStep(3)
       else
          te1(j) = output%energyBins(4)%lowerBound + &
               & output%energyBinSubStep(4)*dble(j3-1)
          te2(j) = te1(j) + output%energyBinSubStep(4)
       endif
       dtt(j) = te2(j) - te1(j)

!  KKG 10/13/04; AJS 02/15/05
       log1 = te1(j) >= tkmax
       temp = 0.0_real64
       if (proj%particleFlag == bremsProjFlag) temp = proj%brems%tMax()
       log2 = te1(j) >= (temp * thousand + 30.d0)
       if ((proj%particleFlag /= bremsProjFlag .and. log1) .or. &
            & (proj%particleFlag == bremsProjFlag .and. log2)) then
          ntt = min(j, 198)
          nt2 = ntt + 1
          nt3 = ntt + 2
          go to 20
       endif
    end do
    ntt = 198
    nt2 = 199
    nt3 = 200

20  output%fisonly = .false.
    if (output%multiplicities == 2) output%fisonly = .true.
    if (output%energySpectra == 2) output%fisonly = .true.
    if (output%doubleDiffSpectra == 2) output%fisonly = .true.
    if (output%angularSpectra == 2) output%fisonly = .true.
!    iz0 = 0
    istp = 0
    neq = 0
    npreq = 0
    nres = 0
    nret = 0
!    azro = zro
    bftot = zro
    bfsq = zro
    bfmin = 100.d0
    bfmax = zro
!    elzro = zro
    estart = zro
    estarsq = zro
    estrmn = thousand
    estrmx = zro
    eestt = zro
    eestsq = zro
    eestrmn = thousand
    eestrmx = zro
    epstt = zro
    epstsq = zro
    epstrmn = thousand
    epstrmx = zro
    erkt = zro
    erksq = zro
    erkmn = thousand
    erkmx = zro
    atot = zro
    atsq = zro
    ammax = zro
    ammin = 400.d0
    aemin = 400.d0
    aemax = zro
    aeqtot = zro
    aeqsq = zro
    apmin = 400.d0
    apmax = zro
    apqtot = zro
    apqsq = zro
    armin = 400.d0
    armax = zro
    artot = zro
    arsq = zro
    artmin = 400.d0
    artmax = zro
    arttot = zro
    artsq = zro
    elsq = zro
    eltot = zro
    elmmax = zro
    elmmin = 100.d0
    eletot = zro
    elesq = zro
    elemin = 100.d0
    elemax = zro
    elptot = zro
    elpsq = zro
    elpmin = 100.d0
    elpmax = zro
    elrtot = zro
    elrsq = zro
    elrmin = 100.d0
    elrmax = zro
    elrttot = zro
    elrtsq = zro
    elrtmin = 100.d0
    elrtmax = zro
    totke = zro
    ztot = zro
    ztsq = zro
    zmmax = zro
    zmmin = 100.d0
    zeqtot = zro
    zeqsq = zro
    zemin = 100.d0
    zemax = zro
    zpqtot = zro
    zpqsq = zro
    zpmin = 100.d0
    zpmax = zro
    zrtot = zro
    zrsq = zro
    zrmin = 100.d0
    zrmax = zro
    zrttot = zro
    zrtsq = zro
    zrtmin = 100.d0
    zrtmax = zro

    !$OMP end critical

    return
  end subroutine initial