* METRo : Model of the Environment and Temperature of Roads
* METRo is Free and is proudly provided by the Government of Canada
* Copyright (C) Her Majesty The Queen in Right of Canada, Environment Canada, 2006

*  Questions or bugs report: metro@ec.gc.ca
*  METRo repository: https://gna.org/projects/metro/
*  Documentation: http://documentation.wikia.com/wiki/METRo
*
*
* Code contributed by:
*  Louis-Philippe Crevier - Canadian meteorological center
*  Miguel Tremblay - Canadian meteorological center
*
*  $LastChangedDate$
*  $LastChangedRevision$
*
************************************************************************
*  This program is free software; you can redistribute it and/or modify
*  it under the terms of the GNU General Public License as published by
*  the Free Software Foundation; either version 2 of the License, or
*  (at your option) any later version.
*
*  This program is distributed in the hope that it will be useful,
*  but WITHOUT ANY WARRANTY; without even the implied warranty of
*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*  GNU General Public License for more details.
*
*  You should have received a copy of the GNU General Public License
*  along with this program; if not, write to the Free Software
*  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
*
*
*

***
*     Subroutine COUPLA: Do the coupling between the atmospheric forecast
*                        and the observations of the RWIS station.
*     Sous-routine COUPLA: effectue le couplage des previsions  avec
*                          les observations des stations meteo-routieres
*
*     Auteur /  Author: Louis-Philippe Crevier
*     Date: Aout 1999 / August 1999
***
      SUBROUTINE COUPLA ( FS, FI, P0, TA , QA , VA , TYP, FT, PR,
     *                    PVC , iref, NTP, NTP2, NTFM, CNT_IN, ITP, TSO,
     *                    FLAT,
     *                    FCOR, WW , WA, ALN, ALR, FP,
     *                    FSCORR   , FICORR  , ER1, ER2,
     *                    FAIL, EPSILON, Z0, Z0T, ZU, ZT, ECHEC,
     *                    dpRA, dpSN, npRC, dpRT, dpIR, dpSF, dpFV,
     *                    dpFC, dpFA, dpG, dpBB, dpFP, TMTTYP)

      IMPLICIT NONE
      INTEGER i, j
      INTEGER Nl, n
      REAL DT
      INTEGER DTMAX
      REAL PADDING
      COMMON /BUFFER_SIZE/ DTMAX, Nl, DT, PADDING, n

***                 ***
*     DEFINITIONS     *
***                 ***
***
*     Input
*     -------
*     FS: Incident solar flux (W)
*     FI: Incident infra-red flux (W)
*     P0: Surface pressure (Pa)
*     TA: Air temperature (C) at level ZT
*     QA: Specific humidity (g/kg) at level ZT
*     VA: Wind (m/s) at level ZU
*     TYP: Probable type of precipitation ( 1 -> rain, 2 -> snow )
*     FT: "Forecast time" (GMT)
*     PR: Precipitation rate (m/s)
*     PVC: Road condition (0 [dry] ou 1 [wet])
*     iref: Number of levels in the grid
*     NTP: Index for the start of coupling
*     NTP2: Index for the end of coupling
*     NTFM: Index for the end of forecast (Added by Cowie for FS check)
*     CNT: Grid constants
*     Z0: Roughness length (m)
*     Z0T: Roughness length (m)
*     ZU: Height of level of the wind forecast (m)
*     ZT:  Height of level of the atmospheric forecast (m)
*     EPSILON: Road emissivity
*     TS0: Target temperature for the end of coupling (C)
*     FCOR: Coriolis factor
*     WW: Minimum winds for the day and the night (m/s)
*     WA: Anthropogenic flux
*     ALN: Snow Albedo
*     ALR: Road Albedo
*     FP: Frozing point (C)
*     FLAT: Road or bridge
***
      LOGICAL FLAT
      INTEGER iref, NTP, NTP2, NTFM
      DOUBLE PRECISION  FS(DTMAX), FI(DTMAX), TA(DTMAX)
      DOUBLE PRECISION QA(DTMAX), PR(DTMAX)
      DOUBLE PRECISION VA(DTMAX), P0(DTMAX), FT(DTMAX)
      DOUBLE PRECISION TYP(DTMAX), PVC(DTMAX)
      DOUBLE PRECISION CNT(n,2), CNT_IN(2*n)
      DOUBLE PRECISION FCOR, WW(2), WA
      DOUBLE PRECISION ALN, ALR, TSO, FP
      DOUBLE PRECISION EPSILON, ZU, ZT, Z0, Z0T
      DOUBLE PRECISION dpSN(DTMAX), dpRA(DTMAX)
      DOUBLE PRECISION dpIR(DTMAX), dpSF(DTMAX)
      DOUBLE PRECISION dpFC(DTMAX), dpFA(DTMAX)
      DOUBLE PRECISION dpG(DTMAX), dpBB(DTMAX)
      DOUBLE PRECISION dpRT(DTMAX), dpFV(DTMAX)
      DOUBLE PRECISION dpFP(DTMAX)
      INTEGER TMTTYP
      INTEGER npRC(DTMAX)
      INTEGER nCheckBefore, nCheckAfter, nTimeStepsIn3Hours
***
*     I/O
*     ---------------
*     ITP: Road temperature profile  (C, iref levels != 0)
***
      LOGICAL ECHEC
      DOUBLE PRECISION ITP(n)
***
*     Output
*     -------
*     FAIL: Tells if the coupling have failed or not
*     TS: Time series for the surface temperature
*     FSCORR: Coupling Coefficient for the solar flux
*     FICORR: Coupling Coefficient for the infra-red flux
*     ER1: Water quantity of the road (mm)
*     ER2: Water Equivalent for ice/snow on the road (mm)
***
      LOGICAL FAIL
      DOUBLE PRECISION  FSCORR, FICORR, ER1, ER2
***
*     Internes
*     --------
***
      INTEGER ier, CHKDIV
      EXTERNAL CHKDIV
      CHARACTER*250 outfmt
      INTEGER next, now, iter
      LOGICAL DOWN
      REAL T(n,2), G(0:n)
      REAL RA, QG, RHO, TSK, AL, COUDUR, M
      REAL CL, PR1, PR2, DX, PRG, FZ
      REAL coeff1, coeff2, cotemp, COFS, COFI
***
*     Variables of FLXSURFZ
*     ---------------------
***
      REAL CMU, CTU, RIB,  ILMO, FTEMP, FVAP
      REAL H, UE, LZZ0, LZZ0T, FM, FH
***
*     Initialisation of common CLELOG
*     -------------------------------
***

      REAL  TCDK
      REAL CPD, CPV, RGASD, RGASV, TRPL, RAUW, EPS1
      REAL DELTA, CAPPA, TGL, CONSOL, GRAV, RAYT, STEFAN, PI
      REAL OMEGA, EPS2
      REAL KNAMS, STLO, KARMAN, RIC, CHLC, CHLF, DG2RAD

      COMMON/CTSPHY/  CPD, CPV, RGASD, RGASV, TRPL, TCDK, RAUW,
     $                EPS1, EPS2, DELTA, CAPPA, TGL, CONSOL,
     $                GRAV, RAYT, STEFAN, PI, OMEGA,
     $                KNAMS, STLO, KARMAN, RIC, CHLC, CHLF, DG2RAD

      REAL TTT,PRS,QQQ,EEE,TVI,QST
      REAL FOEW,FODLE,FOQST,FODQS,FOEFQ,FOQFE,FOTVT,FOTTV,FOHR
      REAL FOEWA,FODLA,FOQSA,FODQA,FOHRA

      LOGICAL bSilent
      COMMON /SILENT/ bSilent

      INTRINSIC SIGN

*   DEFINITION DES FONCTIONS THERMODYNAMIQUES DE BASE
*   POUR LES CONSTANTES, UTILISER LE COMMON /CTESDYN/
*     NOTE: TOUTES LES FONCTIONS TRAVAILLENT AVEC LES UNITES S.I.
*           I.E. TTT EN DEG K, PRS EN PA, QQQ EN KG/KG
*          *** N. BRUNET - MAI 90 ***
*          * REVISION 01 - MAI 94 - N. BRUNET
*                          NOUVELLE VERSION POUR FAIBLES PRESSIONS
*
*     FONCTION DE TENSION DE VAPEUR SATURANTE (TETENS) - EW OU EI SELON TT
      FOEW(TTT) = 610.78*EXP( AMIN1(SIGN(17.269,TTT-TRPL),SIGN
     W (21.875,TTT-TRPL))*ABS(TTT-TRPL)/(TTT-35.86+AMAX1(0.,SIGN
     W (28.2,TRPL-TTT))))
*
*     FONCTION CALCULANT LA DERIVEE SELON T DE  LN EW (OU LN EI)
      FODLE(TTT)=(4097.93+AMAX1(0.,SIGN(1709.88,TRPL-TTT)))
     W /((TTT-35.86+AMAX1(0.,SIGN(28.2,TRPL-TTT)))*(TTT-35.86+AMAX1(0.
     W ,SIGN(28.2,TRPL-TTT))))
*
*     FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE (QSAT)
      FOQST(TTT,PRS)=EPS1/(AMAX1(1.,PRS/FOEW(TTT))-EPS2)
*
*     FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
      FODQS(QST,TTT)=QST*(1.+DELTA*QST)*FODLE(TTT)
*     QST EST LA SORTIE DE FOQST
*
*     FONCTION CALCULANT TENSION VAP (EEE) FN DE HUM SP (QQQ) ET PRS
      FOEFQ(QQQ,PRS) = AMIN1(PRS,(QQQ*PRS) / (EPS1 + EPS2*QQQ))
*
*      FONCTION CALCULANT HUM SP (QQQ) DE TENS. VAP (EEE) ET PRES (PRS)
      FOQFE(EEE,PRS) = AMIN1(1.,EPS1*EEE / (PRS-EPS2*EEE))
*
*      FONCTION CALCULANT TEMP VIRT. (TVI) DE TEMP (TTT) ET HUM SP (QQQ)
      FOTVT(TTT,QQQ) = TTT * (1.0 + DELTA*QQQ)
*
*      FONCTION CALCULANT TTT DE TEMP VIRT. (TVI) ET HUM SP (QQQ)
      FOTTV(TVI,QQQ) = TVI / (1.0 + DELTA*QQQ)
*
*      FONCTION CALCULANT HUM REL DE HUM SP (QQQ), TEMP (TTT) ET PRES (PRS)
*      HR = E/ESAT
       FOHR(QQQ,TTT,PRS) = AMIN1(PRS,FOEFQ(QQQ,PRS)) / FOEW(TTT)
*
*     LES 5 FONCTIONS SUIVANTES SONT VALIDES DANS LE CONTEXTE OU ON
*     NE DESIRE PAS TENIR COMPTE DE LA PHASE GLACE DANS LES CALCULS
*     DE SATURATION.
*   FONCTION DE VAPEUR SATURANTE (TETENS)
      FOEWA(TTT)=610.78*EXP(17.269*(TTT-TRPL)/(TTT-35.86))
*   FONCTION CALCULANT LA DERIVEE SELON T DE LN EW
      FODLA(TTT)=17.269*(TRPL-35.86)/(TTT-35.86)**2
*   FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE
      FOQSA(TTT,PRS)=EPS1/(AMAX1(1.,PRS/FOEWA(TTT))-EPS2)
*   FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
      FODQA(QST,TTT)=QST*(1.+DELTA*QST)*FODLA(TTT)
*   FONCTION CALCULANT L'HUMIDITE RELATIVE
      FOHRA(QQQ,TTT,PRS)=AMIN1(PRS,FOEFQ(QQQ,PRS))/FOEWA(TTT)
*
***
*
*     Procedure
*     =========
      if( .not. bSilent) then
         WRITE(*,*) "DEBUT COUPLA"
      end if
*****
**     Conversion of array in matrix
      CALL ARRAY2MATRIXDOUBLEPRECISION(CNT_IN, CNT , n, 2)
**     Initialisation of parametres
**     ++++++++++++++++++++++++++++
      FAIL = .FALSE.
      DOWN = .FALSE.
      FZ = 0.1
      iter = 0
      coeff1 = 0.
      coeff2 = 1.
      ILMO = 1.
*     Compute the length of coupling
      COUDUR = real(NTP2-NTP+1)*DT/3.6e3
*     Initialization of albedo variation due to snow presence
*     ---------------------------------------------------------------
*     |                                                             |
*     |  See balanc.F for the description of the function used      |
*     |                                                             |
*     ---------------------------------------------------------------
      M = (ALN - ALR) / 5.
 11   next = 1
      now = 2
      H = 300.0
      ER1 = 0.0
      ER2 = 0.0
      iter = iter + 1
      G(0) = 0.0
      do j=1,iref
         T(j,now)=REAL(ITP(j))
         T(j,next)=REAL(ITP(j))
         G(j) = 0.
      end do

************************************************
*    Criterium: Solar flux must be non zero
*     during the 3 hours BEFORE the roadcast and
*     1 hour AFTER the begining of the roadcast.
      nTimeStepsIn3Hours = 3*3600./DT
      if (NTP2 - nTimeStepsIn3Hours > NTP) then
         nCheckBefore = NTP2-nTimeStepsIn3Hours
      else
         nCheckBefore = NTP
      end if
      if (NTP2 + nTimeStepsIn3Hours/3 < DTMAX) then
         nCheckAfter = NTP2+nTimeStepsIn3Hours/3
      else
         nCheckAfter = DTMAX
      end if

*     avoid going off array. Also, added +1 to NPT2 index below
*     because it can be 0. (Cowie)
      nCheckBefore = max(1, nCheckBefore)
      nCheckAfter = min(DTMAX, nCheckAfter)

      if(FS(nCheckBefore) > 0.0 .and.
     *   FS(NTP2+1) > 100.0 .and.
     *   FS(nCheckAfter) > 0.0) then
         COFI = 1.0
         COFS = coeff2
      else
*        Nuit
         COFI = coeff2
         COFS = 1.0
      end if

*     +++++++++++++++++++++++++++++++++
*     Entry of the coupling loop
*     +++++++++++++++++++++++++++++++++
      do i = NTP+1,NTP2
*        Adjustement of the road conditions
*        +++++++++++++++++++++++++++++++++++++
         ER1 = PVC(i)*ER1
         ER2 = PVC(i)*ER2
*        Preparation of differents terms of balance
*        ++++++++++++++++++++++++++++++++++++++++++
*        road temp in Kelvins
         TSK = T(1,now) + TCDK
*        Black body radiation
         RA = EPSILON*STEFAN*TSK**4
*        Humidity at the surface
         call SRFHUM  ( QG, CL, ER1, ER2, TSK, P0(i), QA(i), FP )
*        Air density at ground
         ier = CHKDIV ( RGASD * FOTVT ( TSK , QG ), "coupla.ftn", 209 )
         if ( ier .eq. 1 ) then
            ECHEC = .true.
            return
         end if
         RHO = P0(i) / ( RGASD * FOTVT ( TSK , QG ) )
*        Wind modification
         call VENMIN  ( WW, FT(i), VA(i) )
*        Energy used/free by the melting snow/freezing rain
         call VERGLAS ( TYP(i), T(1,now), FP, FZ, PR(i),
     *                  PR1, PR2, PRG, FAIL )
*        Heat flux coefficients
         call FLXSURFZ( CMU  , CTU , RIB  , FTEMP, FVAP ,
     *                  ILMO, UE   , FCOR , TA(i)+TCDK,
     *                  QA(i), ZU, ZT  , VA(i), TSK  , QG   ,
     *                  H    , Z0  , Z0T  , LZZ0 , LZZ0T,
     *                  FM   , FH  ,  1,  1     )
*        Effective albedo
         AL = 1.0 - max( ALR,min( ALN,M*ER2+ALR-M ) )
*        Energetic balance computation
*        +++++++++++++++++++++++++++
         G(0) = max(0.0,REAL(COFS*AL*FS(i))) - RA
     *        + COFI*EPSILON*FI(i)
     *        + RHO*CTU*( CPD*(TA(i)-T(1,now))
     *        + CL*(QA(i)-QG)) + PRG + WA
*        Output information
         dpIR(i) = COFI*EPSILON*FI(i)
         dpSF(i) = COFS*AL*FS(i)
         dpFV(i) = RHO*CTU*(CL*(QA(i)-QG))
         dpBB(i) = - RA
         dpFC(i) =  RHO*CTU*( CPD*(TA(i)-T(1,now)))
         dpFA(i) = WA
         dpFP(i) = PRG
         dpG(i) = G(0)

         G(1) = REAL(CNT(1,1) * ( T(2,now) - T(1,now) ))
         T(1,next) = REAL(T(1,now)+DT*(CNT(1,2)*( G(1) - G(0)) ))

         DX = 0.0
*        Compute the evolution of temperature in the ground
*        +++++++++++++++++++++++++++++++++++++++++++++++++
         call TSEVOL ( T, iref, now, CNT, G, FLAT, TA(i) )
*        Balance of accumulation at the ground
*        ++++++++++++++++++++++++++++++
         call RODCON ( ER1, ER2, RHO  , CTU, CL , FP , FZ ,
     *                 T(1,now), QA(i), QG , PR1, PR2, PRG, DX ,
     *                 npRC(i), TMTTYP)

         dpRT(i) = T(1,next)
         dpRA(i) = ER1
         dpSN(i) = ER2

*        Inversion of indices
*        +++++++++++++++++++++
         next = 3 - next
         now = 3 - now
      end do
*      if ( VERBOSE ) then
         FSCORR = COFS - 1.0
         FICORR = COFI - 1.0
         write(outfmt,223) iter, COUDUR,
     *        min(99.99,max(-99.99,T(1,now))),
     *        min(99.99,max(-99.99,REAL(TSO))),COFI,COFS
*      end if
*     Check if other iterations are necessary
*     +++++++++++++++++++++++++++++++++++++++++++
      if ( iter .eq. 25 ) then
         FICORR = 0.0
         FSCORR = 0.0
         FAIL = .true.
         WRITE(*,*) "More than 25 iterations in the coupling phase "
      else if ( abs(min(99.99,max(-99.99,T(1,now)))) .eq. 99.99 .or.
     *        FAIL ) then
         FICORR = 0.0
         FSCORR = 0.0
         write(outfmt,223) iter, COUDUR,
     *        min(99.99,max(-99.99,T(1,now))),
     *        min(99.99,max(-99.99,REAL(TSO))),COFI,COFS
         FAIL = .true.
         WRITE(*,*) " Temperature over 99 degrees, aborting in coupling"
      else if ( mod(iter,15) .eq. 0 .and.
     *        min(REAL(max(T(1,now),REAL(TSO-0.1))),REAL(TSO+0.1))
     *    .ne. T(1,now) ) then
         coeff1 = 0.0
         coeff2 = 1.5*coeff2
         go to 11
      else if ( T(1,now) - TSO .gt. 0.1 ) then
         coeff2 = coeff2 - 0.5*(coeff2-coeff1)
         DOWN = .true.
         go to 11
      else if ( TSO - T(1,now) .gt. 0.1 ) then
        if ( DOWN ) then
           cotemp = coeff1
           coeff1 = coeff2
           coeff2 = coeff2 + 0.5*(coeff2-cotemp)
         else
            cotemp = coeff1
            coeff1 = coeff2
            coeff2 = 2.0*coeff2 - cotemp
         end if
         go to 11
      else
         FSCORR = COFS - 1.0
         FICORR = COFI - 1.0
         FAIL = .false.
         do j=1,iref
            ITP(j) = T(j,now)
         end do
      end if
 223  format(1x,i3,3x,f5.2,3x,f6.2,3x,f6.2,f9.5,f9.5)

**     Conversion of matrix in array
      CALL MATRIX2ARRAYDOUBLEPRECISION(CNT, CNT_IN, n, 2)

      if( .not. bSilent) then
         WRITE(*,*) "FIN COUPLA"
      end if

      RETURN
      END


      SUBROUTINE DT_SPLFLA(Nn,Mode)

C***********************************************************************
C SamPLing of FLAvors of partons at chain ends.                        *
C This subroutine replaces FLKSAA/FLKSAM.                              *
C            NN            number of nucleon-nucleon interactions      *
C            MODE = 1      sea-flavors                                 *
C                 = 2      valence-flavors                             *
C Based on the original version written by J. Ranft/H.-J. Moehring.    *
C This version dated 16.01.95 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION DT_RNDM
      INTEGER i , MAXINT , MAXNCL , MAXSQU , MAXVQU , Mode , Nn
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (MAXNCL=260,MAXVQU=MAXNCL,MAXSQU=20*MAXVQU,
     &           MAXINT=MAXVQU+MAXSQU)
C flavors of partons (DTUNUC 1.x)
      INCLUDE 'inc/dtdpmf'
C auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
      INCLUDE 'inc/dtdpmi'
C auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
      INCLUDE 'inc/dtdpm0'
C particle properties (BAMJET index convention)
      INCLUDE 'inc/dtpart'
C various options for treatment of partons (DTUNUC 1.x)
C (chain recombination, Cronin,..)
      INCLUDE 'inc/dtchai'

      IF ( Mode.EQ.1 ) THEN
C sea-flavors
         DO i = 1 , Nn
            IPSq(i) = INT(1.0D0+DT_RNDM(CROnco)*(2.0D0+SEAsq))
            IPSaq(i) = -IPSq(i)
         END DO
         DO i = 1 , Nn
            ITSq(i) = INT(1.0D0+DT_RNDM(CROnco)*(2.0D0+SEAsq))
            ITSaq(i) = -ITSq(i)
         END DO
      ELSE IF ( Mode.EQ.2 ) THEN
C valence flavors
         DO i = 1 , IXPv
            CALL DT_FLAHAD(KKProj(IFRovp(i)),IPVq(i),IPPv1(i),IPPv2(i))
         END DO
         DO i = 1 , IXTv
            CALL DT_FLAHAD(KKTarg(IFRovt(i)),ITVq(i),ITTv1(i),ITTv2(i))
         END DO
      END IF

      END SUBROUTINE


      subroutine rdopac (ilib,illib)
c***********************************************************************
c Read material opacities as a function of temperature and density
c
c Modified 3/15/01 bmb: For file system scalability, substituted
c MPI_Bcast instead of having each task read the input file individually.
c Also disabled read/write of binary opacity file for ASCI Purple
c benchmark purposes. It is not portable.  Therefore, the ilib input
c file parameter must be 1.  The illib parameter is ignored.
c***********************************************************************

c     matl code   matl
c     1             h
c     2             sio2
c     3             dt
c     4             c

      implicit double precision (a-h,o-z)

      include 'mpif.h'

      DOUBLE PRECISION x(14,32,13,4), t(32,2), d(14)
      integer ierr, myid

      common /opactab/ x, t, d

      CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)

      if (ilib .eq. 1) then

c     TEXT read of the opacity file.
c     Task 0 is only task to actually perform I/O.  It then
c     broadcasts the input file via MPI_BCAST to all other tasks

        if (myid .eq. 0) then
          open (4, file='opac.txt')
          do 701 l = 1,4
            do 701 k = 1,13
              do 701 j = 1,32
                do 701 i = 1,14
                  read (4,704) x(i,j,k,l)
 701      continue
 704      format (e20.4)
          close (4)
        endif

        CALL MPI_BARRIER(MPI_COMM_WORLD, ierr)
        CALL MPI_BCAST(x, 23296, MPI_DOUBLE_PRECISION, 0,
     +     MPI_COMM_WORLD, ierr)

      endif

      if (ilib .ne. 1) then

        if (myid .eq. 0) then
        print *, " "
        print *, "ERROR: rdopac routine:"
        print *, "Read/write of binary opacity file feature is not"
        print *, "enabled for ASCI Purple benchmark purposes. Please "
        print *, "check your input file and make sure that the ilib"
        print *, "parameter = 1."
        print *, " "
        endif

        CALL MPI_FINALIZE(ierr)
        stop

      endif

c
c     if(illib .ne. 0 .and. ilib .ne. 1) then
c--------------------do a BINARY write of the opacity file
c           open (15, file=  'opac.bin',
c    |           access='sequential',
c    |           form=  'unformatted',
c    |           status='new')
c     write (15) x
c           do 88804 l=1,4
c              do 88804 k=1,13
c                 write(15)
c    .                 ((x(i,j,k,l),i=1,14),j=1,32)
c88804          continue
c              close (15)
c              stop
c           endif
c
c        else
c--------------------do a BINARY read of the opacity file
c           open (15, file=  'opac.bin',
c    |           access='sequential',
c    |           form=  'unformatted',
c    |           status='old')
c     read (15) x
c           do 88805 l=1,4
c              do 88805 k=1,13
c                 read(15)
c    .                 ((x(i,j,k,l),i=1,14),j=1,32)
c88805          continue
c              close(15)
c           endif

      return
      end

      BLOCK DATA RDOINIT

      implicit double precision (a-h,o-z)

      DOUBLE PRECISION x(14,32,13,4), t(32,2), d(14)

      common /opactab/ x, t, d

c     temperatures for tabulated opacities (64 total):
c     first  set of 32 for material 1 or 3 (h or d),
c     second set of 32 for material 2 or 4 (sio2 or c).

      data t / 79.d0,99.d0,125.d0,157.d0,198.d0,250.d0,315.d0,397.d0,
     + 500.d0,630.d0,974.d0,
     +     1000.d0,1260.d0,1587.d0,2000.d0,2520.d0,3175.d0,4000.d0,
     +  5040.d0,6350.d0,8000.d0,
     +     10079.d0,12699.d0,16000.d0,20159.d0,25398.d0,32000.d0,
     + 40317.d0,50797.d0,64000.d0,
     +     80635.d0,101594.d0,
     +     20.d0,25.d0,31.d0,39.d0,50.d0,63.d0,79.d0,99.d0,125.d0,
     + 157.d0,198.d0,250.d0,315.d0,397.d0,
     +     500.d0,630.d0,974.d0,1000.d0,1260.d0,1587.d0,2000.d0,2520.d0,
     + 3175.d0,4000.d0,5040.d0,
     +     6350.d0,8000.d0,10079.d0,12699.d0,16000.d0,20159.d0,25398.d0/

c     densities for tabulated opacities (14 total)

      data d / 3.162d-4,1.000d-3,3.162d-3,1.000d-2,3.162d-2,1.000d-1,
     .     3.162d-1,1.000d+0,3.162d+0,1.000d+1,3.162d+1,1.000d+2,
     .     3.162d+2,1.000d+3/

      END


cdis
cdis    Open Source License/Disclaimer, Forecast Systems Laboratory
cdis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
cdis
cdis    This software is distributed under the Open Source Definition,
cdis    which may be found at http://www.opensource.org/osd.html.
cdis
cdis    In particular, redistribution and use in source and binary forms,
cdis    with or without modification, are permitted provided that the
cdis    following conditions are met:
cdis
cdis    - Redistributions of source code must retain this notice, this
cdis    list of conditions and the following disclaimer.
cdis
cdis    - Redistributions in binary form must provide access to this
cdis    notice, this list of conditions and the following disclaimer, and
cdis    the underlying source code.
cdis
cdis    - All modifications to this software must be clearly documented,
cdis    and are solely the responsibility of the agent making the
cdis    modifications.
cdis
cdis    - If significant modifications or enhancements are made to this
cdis    software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
cdis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
cdis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
cdis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
cdis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
cdis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
cdis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
cdis
cdis

      FUNCTION GIMRAD(TAU,TEMP,TSKIN,KCHAN,LSFC,PSFC,EMISS)
c  12 dec 94  correct error in sfc tau extrapolation
C $ FUNCTION GIMRAD(TAU,TEMP,TSKIN,KCHAN,LSFC,PSFC,EMISS)   (HMW)
C $ GIMRAD - compute GOES radiance from temperature profile
C $ Input:
C $     TAU = (R) array of GOES transmittances
C $     TEMP = (R) array of atmospheric temperatures
C $     TSKIN = (R) temperature of surface
C $     KCHAN = (I) channel number
C $     LSFC = (I) subscript of level below or at surface
C $     PSFC = (I) pressure of surface ( or cloud)
C $     EMISS = (R) surface emissivity
C $ Output description:
C $     GOES radiance
C $$ GIMRAD = SOUNDER, GOES, CONVERT
      DIMENSION TAU(*),TEMP(*)
      COMMON/ATMOS/P(40),T(40),W(40),OZO(40)
      COMMON /ATMRAD/ATRD,TAUS,REFL
C     PREPARE SURFACE CORRECTION
      DP = ALOG(PSFC/P(LSFC))/ALOG(P(LSFC)/P(LSFC-1))
C     DP IS NEGATIVE TO INTERPOLATE, POSITIVE TO EXRAPOLATE (PSFC>NL)
      DTAU = TAU(LSFC-1)-TAU(LSFC)
      TAUS = TAU(LSFC)-DTAU*DP
      REFL = 0.
      T1 = TEMP(1)
      B1 = PLANGO(T1,KCHAN)
      TAU1 = TAU(1)
      RAD = 0.
C     INTEGRATE DOWN TO LEVEL AT OR BELOW SURFACE
      DO 110 I = 2,LSFC
      T2 = TEMP(I)
      B2 = PLANGO(T2,KCHAN)
      TAU2 = TAU(I)
      DTAU = TAU1-TAU2
      DR =.5*(B1+B2)*DTAU
      IF (TAUS .GT. 0.1.AND.EMISS .LT. 1.00)THEN
C     DO NOT ADD REFLECTED FOR LAST LEVEL UNLESS PSFC .GT. 1000
      IF (I .EQ. LSFC.AND.PSFC .LE. 1000.)GO TO 105
      TAUB = 0.5*(TAU1+TAU2)
      TAUFAC = TAUS/TAUB
      REFL = REFL+TAUFAC*TAUFAC*DR
      ENDIF
  105 RAD = RAD+DR
      B1 = B2
  110 TAU1 = TAU2
C     ADD (SUBTRACT) INCREMENT OF ATMOS RADIANCE TO REACH SURFACE
C     DP WILL BE NEGATIVE IF PSFC  < 1000 MB
C     DR FALLS OUT AS THE DELTA RADIANCE OF LAYER
      RAD = RAD+DR*DP
C     ADD INCREMENT OF REFLECTED RADIANCE FOR LAYER DOWN TO SURFACE
      IF (TAUS .GT. 0.1.AND.EMISS .LT. 1.00)THEN
         IF (PSFC .LT. 1000.)THEN
         TAUB = 0.5*(TAU(LSFC-1)+TAUS)
C     CHANGE DP TO INCREMENT RATHER THAN DECREMENT
         DP = 1.+DP
         ELSE
         TAUB = 0.5*(TAU(LSFC)+TAUS)
         ENDIF
      TAUFAC = TAUS/TAUB
      REFL = REFL+TAUFAC*TAUFAC*DR*DP
      ENDIF
      ATRD = RAD
      RAD = RAD+(1.-EMISS)*REFL
      BS = PLANGO(TSKIN,KCHAN)
      RAD = RAD+EMISS*BS*TAUS
      RAD = AMAX1(RAD,.001)
      GIMRAD = RAD
      RETURN
      END


c.....driver program for A Multi-Phase Transport model
      PROGRAM AMPT
c
      double precision xmp, xmu, alpha, rscut2, cutof2, dshadow
      double precision smearp,smearh,dpcoal,drcoal,ecritl
      CHARACTER FRAME*8, PROJ*8, TARG*8
      character*25 amptvn
      COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11
      COMMON /HPARNT/HIPR1(100), IHPR2(50), HINT1(100), IHNT2(50)
      COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
      COMMON /AROUT/ IOUT
      COMMON /AREVT/ IAEVT, IARUN, MISS
      COMMON /smearz/smearp,smearh
      COMMON/RNDF77/NSEED
      common/anim/nevent,isoft,isflag,izpc
c     parton coalescence radii in case of string melting:
      common /coal/dpcoal,drcoal,ecritl
      common/snn/efrm,npart1,npart2,epsiPz,epsiPt,PZPROJ,PZTARG
c     initialization value for parton cascade:
      common /para2/ xmp, xmu, alpha, rscut2, cutof2
      common /para7/ ioscar,nsmbbbar,nsmmeson
      common /para8/ idpert,npertd,idxsec
      common /rndm3/ iseedp
c     initialization value for hadron cascade:
      COMMON /RUN/ NUM
      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
      COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
     &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
      common/oscar1/iap,izp,iat,izt
      common/oscar2/FRAME,amptvn
      common/resdcy/NSAV,iksdcy
clin-4/2012-6/2009:
c      common/phidcy/iphidcy
      common/phidcy/iphidcy,pttrig,ntrig,maxmiss,ipi0dcy
      common/embed/iembed,nsembd,pxqembd,pyqembd,xembd,yembd,
     1     psembd,tmaxembd,phidecomp
clin-7/2009:
      common/cmsflag/dshadow,ishadow
clin-2/2012 allow random orientation of reaction plane:
      common /phiHJ/iphirp,phiRP

      EXTERNAL HIDATA, PYDATA, LUDATA, ARDATA, PPBDAT, zpcbdt
      SAVE
c****************
      OPEN (24, FILE = 'input.ampt', STATUS = 'UNKNOWN')
      OPEN (12, FILE = 'ana/version', STATUS = 'UNKNOWN')
      READ (24, *) EFRM
c     format-read characters (for ALPHA compilers):
      READ (24, 111) FRAME
      READ (24, 111) PROJ
      READ (24, 111) TARG
      READ (24, *) IAP
      READ (24, *) IZP
      READ (24, *) IAT
      READ (24, *) IZT
      READ (24, *) NEVNT
      READ (24, *) BMIN
      READ (24, *) BMAX
c     flag to select default AMPT or string melting:
      READ (24, *) isoft
c     read initialization value for hadron cascade:
      READ (24, *) NTMAX
      READ (24, *) DT
c     parj(41) and (42) are a and b parameters in Lund string fragmentation:
      READ (24, *) PARJ(41)
      READ (24, *) PARJ(42)
c     IHPR2(11)=3 (or 2) allows the popcorn mechanism in PYTHIA and
c     increase the net-baryon stopping in rapidity (value HIJING is 1):
      READ (24, *) ipop
      if(ipop.eq.1) IHPR2(11)=3
c     PARJ(5) controls the fraction of BMBbar vs BBbar in popcorn:
      READ (24, *) PARJ(5)
c     shadowing flag in HIJING:
      READ (24, *) IHPR2(6)
c     quenching flag in HIJING:
      READ (24, *) IHPR2(4)
c     quenching rate when quenching flag is on (=1.0 GeV/fm):
      READ (24, *) HIPR1(14)
c     Minimum pt of hard or semihard scatterings in HIJING: D=2.0 GeV.
      READ (24, *) HIPR1(8)
c     read initialization value for parton cascade:
      READ (24, *) xmu
      READ (24, *) izpc
      READ (24, *) alpha
c     quark coalescence radii in momentum and space for string melting:
      READ (24, *) dpcoal
      READ (24, *) drcoal
c     flag: read in HIJING random # seed at runtime(1) or from input.ampt(D=0):
      READ (24, *) ihjsed
c     2 seeds for random number generators in HIJING/hadron cascade and ZPC:
      READ (24, *) nseed
      READ (24, *) iseedp
      READ (24, *) iksdcy
      READ (24, *) iphidcy
      READ (24, *) ipi0dcy
c     flag for OSCAR output for final partons and hadrons:
      READ (24, *) ioscar
clin-5/2008     flag for perturbative treatment of deuterons:
      READ (24, *) idpert
      READ (24, *) npertd
      READ (24, *) idxsec
clin-6/2009 To select events that have at least 1 high-Pt minijet parton:
      READ (24, *) pttrig
      READ (24, *) maxmiss
      READ (24, *) IHPR2(2)
      READ (24, *) IHPR2(5)
clin-6/2009 To embed a back-to-back q/qbar pair into each event:
      READ (24, *) iembed
      READ (24, *) pxqembd, pyqembd
      READ (24, *) xembd, yembd
      READ (24, *) nsembd,psembd,tmaxembd
clin-7/2009 Allow modification of nuclear shadowing:
      READ (24, *) ishadow
      READ (24, *) dshadow
      READ (24, *) iphirp
c
      CLOSE (24)
 111  format(a8)
clin-6/2009 ctest off turn on jet triggering:
c      IHPR2(3)=1
c     Trigger Pt of high-pt jets in HIJING:
c      HIPR1(10)=7.
c
      if(isoft.eq.1) then
         amptvn = '1.26t5 (Default)'
      elseif(isoft.eq.4) then
         amptvn = '2.26t5 (StringMelting)'
      else
         amptvn = 'Test-Only'
      endif
      WRITE(6,50) amptvn
      WRITE(12,50) amptvn
 50   FORMAT(' '/
     &11X,'##################################################'/1X,
     &10X,'#      AMPT (A Multi-Phase Transport) model      #'/1X,
     &10X,'#          Version ',a25,                  '     #'/1X,
     &10X,'#                4/06/2015                       #'/1X,
     &10X,'##################################################'/1X,
     &10X,' ')
c     when ihjsed=11: use environment variable at run time for HIJING nseed:
      if(ihjsed.eq.11) then
         PRINT *,
     1 '# Read in NSEED in HIJING at run time (e.g. 20030819):'
      endif
      READ (*, *) nseedr
      if(ihjsed.eq.11) then
         nseed=nseedr
      endif
      if(ihjsed.eq.11) then
         PRINT *, '#   read in: ', nseed
         WRITE(12,*) '# Read in NSEED in HIJING at run time:',nseed
      endif
      CLOSE(12)
clin-5/2015 an odd number is needed for the random number generator:
c      if(mod(NSEED,2).eq.0) NSEED=NSEED+1
      NSEED=2*NSEED+1
c     9/26/03 random number generator for f77 compiler:
      CALL SRAND(NSEED)
c
c.....turn on warning messages in nohup.out when an event is repeated:
      IHPR2(10) = 1
c     string formation time:
      ARPAR1(1) = 0.7
c     smearp is the smearing halfwidth on parton z0,
c     set to 0 for now to avoid overflow in eta.
c     smearh is the smearing halfwidth on string production point z0.
      smearp=0d0
      IAmax=max(iap,iat)
      smearh=1.2d0*IAmax**0.3333d0/(dble(EFRM)/2/0.938d0)
      nevent=NEVNT
c
c     AMPT momentum and space info at freezeout:
      OPEN (16, FILE = 'ana/ampt.dat', STATUS = 'UNKNOWN')
      OPEN (14, FILE = 'ana/zpc.dat', STATUS = 'UNKNOWN')
ctest off for resonance (phi, K*) studies:
c      OPEN (17, FILE = 'ana/res-gain.dat', STATUS = 'UNKNOWN')
c      OPEN (18, FILE = 'ana/res-loss.dat', STATUS = 'UNKNOWN')
      CALL HIJSET(EFRM, FRAME, PROJ, TARG, IAP, IZP, IAT, IZT)
      CALL ARTSET
      CALL INIZPC
clin-5/2009 ctest off:
c      call flowp(0)
c      call flowh0(NEVNT,0)
c      call iniflw(NEVNT,0)
c      call frztm(NEVNT,0)
c
       DO 2000 J = 1, NEVNT
          IAEVT = J
          DO 1000 K = 1, NUM
             IARUN = K
             IF (IAEVT .EQ. NEVNT .AND. IARUN .EQ. NUM) THEN
                IOUT = 1
             END IF
             PRINT *, ' EVENT ', J, ', RUN ', K
             imiss=0
 100         CALL HIJING(FRAME, BMIN, BMAX)
             IAINT2(1) = NATT

clin-6/2009 ctest off
           if(J.eq.-2) then
              write(98,*) HIPR1
              write(98,*) ' '
              write(98,*) IHPR2
              write(98,*) ' '
              write(98,*) (HINT1(i),i=1,20)
              write(98,*) ' '
              write(98,*) (HINT1(i),i=21,40)
              write(98,*) ' '
              write(98,*) (HINT1(i),i=41,60)
              write(98,*) ' '
              write(98,*) (HINT1(i),i=61,80)
              write(98,*) ' '
              write(98,*) (HINT1(i),i=81,100)
              write(98,*) ' '
              write(98,*) IHNT2
           endif

c     evaluate Npart (from primary NN collisions) for both proj and targ:
             call getnp
c     switch for final parton fragmentation:
             IF (IHPR2(20) .EQ. 0) GOTO 2000
c     In the unlikely case of no interaction (even after loop of 20 in HIJING),
c     still repeat the event to get an interaction
c     (this may have an additional "trigger" effect):
             if(NATT.eq.0) then
                imiss=imiss+1
                if(imiss.le.20) then
                   write(6,*) 'repeated event: natt=0,j,imiss=',j,imiss
                   goto 100
                else
                   write(6,*) 'missed event: natt=0,j=',j
                   goto 2000
                endif
             endif
c.....ART initialization and run
             CALL ARINI
             CALL ARINI2(K)
 1000     CONTINUE
c
          CALL ARTAN1
clin-9/2012 Analysis is not used:
c          CALL HJANA3
          CALL ARTMN
clin-9/2012 Analysis is not used:
c          CALL HJANA4
          CALL ARTAN2
 2000  CONTINUE
c
       CALL ARTOUT(NEVNT)
clin-5/2009 ctest off:
c       call flowh0(NEVNT,2)
c       call flowp(2)
c       call iniflw(NEVNT,2)
c       call frztm(NEVNT,2)
c
       STOP
       END
c     FYI: taken file unit numbers are 12-14, 16-88, 91-93;
c     so free file unit numbers are 11,15,89,97-99.


      subroutine tffscalc(kdp,df,iqcol,lfp,
     $     nqcola,nqcola1,ibegin,
     $     r,rp,rstab,nstab,residual1,
     $     zcal,wcal,parallel,lout,error)
      use tfstk
      use ffs, only:ndim,nlat,flv,maxcond,ffs_bound,nvevx,nelvx
      use ffs_flag
      use ffs_pointer
      use ffs_fit
      use ffs_wake
      use tffitcode
      use tfshare
      use tfcsi,only:lfno
      use eeval
      use macmath
      use mathfun
      implicit none
c      include 'DEBUG.inc'
      type (sad_descriptor) kx
      type (ffs_bound) fbound,ibound
      integer*4 ,intent(in):: nqcola,nqcola1,
     $     kdp(maxcond),iqcol(maxcond),lfp(2,maxcond)
      integer*4 ,intent(out):: ibegin
      integer*4 i1,i2,i3,i,ii,j,iter,kt,iq,l,maxf,
     $     ie,ie1,iv,nstab,lout,irtc
      real*8 ,intent(out):: df(maxcond),r,rp,residual1(-ndimmax:ndimmax)
      logical*4 ,intent(in):: parallel
      logical*4 ,intent(out):: error,zcal,wcal
      real*8 anux0,anuy0,anux0h,anuy0h,anuxi,anuyi,anuxih,anuyih,
     $     rw,drw,rstab,wi,anusumi,anusum0,anudiffi,anudiff0
      logical*4 fam,beg,zerores
      integer*4 irw,isw,ipr,ifb,ife,idir,
     $     jjfam(-nfam:nfam),ifpe,ntfun
      integer*4, external :: fork_worker,waitpid,
     $     itfdownlevel,itfuplevel,itgetfpe
      integer*8 iutm,jb
      integer*4 , parameter:: ivoid=9999
      integer*8 ,save :: iprolog=0,iepilog=0,imr=0,inr=0,isl=0
      associate (nvar=>flv%nvar)
c     begin initialize for preventing compiler warning
      anux0=0.d0
      anuy0=0.d0
      anux0h=0.d0
      anuy0h=0.d0
      anusum0=0.d0
      anudiff0=0.d0
      iutm=0
c     end   initialize for preventing compiler warning
      if(iprolog .eq. 0)then
        iprolog=ktfsymbolz('OpticsProlog',12)
        iepilog=ktfsymbolz('OpticsEpilog',12)
        imr=    ktfsymbolz('MatchingResidual',16)-4
        inr=    ktfsymbolz('NetResidual',11)-4
        isl=    ktfsymbolz('StabilityLevel',14)-4
      endif
      ifpe=itgetfpe()
      call tclrfpe
c      call tfmemcheckprint('tffscalc-before-prolog',.true.,irtc)
      l=itfuplevel()
      kx=tfeeval(dfromk(ktfsymbol+iprolog),.true.,irtc)
      l=itfdownlevel()
      if(irtc .ne. 0)then
        if(irtc .gt. 0)then
          if(ierrorprint .ne. 0)then
            call tfaddmessage(' ',0,lfno)
          endif
          call tclrfpe
          call termes(lfno,'Error in OpticsProlog.',' ')
        endif
        error=.true.
        return
      endif
      call tsetfpe(ifpe)
      if(zcal)then
        call tfgeo(latt,geomet .or. .not. fitflg)
      endif
      call tffsbound(fbound)
      optstat(nfam1:nfam)%over=.false.
      optstat(nfam1:nfam)%stabx=.true.
      optstat(nfam1:nfam)%staby=.true.
      optstat(nfam1:nfam)%stabz=.true.
      jjfam(nfam1:nfam)=ivoid
      ntfun=merge(ntwissfun,mfitdetr,orbitcal .or. calc6d)
      beg=ibegin .gt. fbound%lb
      if(beg)then
        twiss(ibegin,0,1:ntfun)
     $       =utwiss(1:ntfun,0,itwissp(ibegin))
        fbound%fb=0.d0
      else
        call twmov(1,twiss,nlat,ndim,.true.)
        twiss(1,0,mfitnx)=0.d0
        twiss(1,0,mfitny)=0.d0
        if(orbitcal)then
          twiss(1,0,mfitddp)=twiss(1,0,mfitddp)+dp(0)
        endif
        if(fbound%lb .gt. 1)then
          twiss(fbound%lb,0,1:ntfun)=twiss(1,0,1:ntfun)
        endif
        ibegin=fbound%lb
      endif
      ibound=fbound
      ibound%lb=ibegin
      if(wake)then
        call tffswake(ibound,beg)
      else
        call qcell1(ibound,0,optstat(0),.false.,chgini,lout)
        call tffssetutwiss(0,nlat,fbound,beg,.true.,.true.)
        if(cell)then
          anux0=aint(twiss(nlat,0,mfitnx)/pi2)
          anuy0=aint(twiss(nlat,0,mfitny)/pi2)
          anux0h=aint(twiss(nlat,0,mfitnx)/pi)
          anuy0h=aint(twiss(nlat,0,mfitny)/pi)
          anusum0=aint((twiss(nlat,0,mfitnx)+twiss(nlat,0,mfitny))/pi2)
          anudiff0=tfloor(
     $         (twiss(nlat,0,mfitnx)-twiss(nlat,0,mfitny))/pi2)
c          anudiff0=twiss(nlat,0,mfitnx)/pi2-
c     $         aint(twiss(nlat,0,mfitnx)/pi2)-
c     $         twiss(nlat,0,mfitny)/pi2+
c     $         aint(twiss(nlat,0,mfitny)/pi2)
          if(optstat(0)%stabx .and. optstat(0)%staby
     $         .and. optstat(0)%stabz .or. chgini)then
            call twmov(1,twiss,nlat,ndim,.false.)
          endif
        endif
        if(nfam .ne. 0)then
          if(parallel)then
            irtc=0
            iutm=ktfallocshared((2*nfam+1)*4)
c            iutm=mapalloc8(rlist(1),(2*nfam+1)*4,8,irtc)
            if(irtc .eq. 0)then
              ipr=fork_worker()
            else
              ipr=-1
            endif
          else
            ipr=-1
          endif
          if(ipr .gt. 0)then
            idir=-1
            ifb=-1
            ife=-nfr
          else
            idir=1
            ifb=1
            ife=nfr
          endif
 2        i1=0
          i2=0
          i3=0
          fam=.false.
 1        do ii=ifb,ife,idir
            if(fam)then
              if(kfam(ii) .eq. 0)then
                cycle
              elseif(ipr .gt. 0 .and. jfam(ii) .ge. 0 .or.
     $               ipr .eq. 0 .and. jfam(ii) .lt. 0)then
                cycle
              endif
              i3=i2
              i2=jfam(ii)
              i1=ii
            else
              i3=i2
              i2=i1
              i1=ii
            endif
            if(optstat(i2)%over)then
              utwiss(1,ii,1:nut)=utwiss(1,i2,1:nut)
              utwiss(mfitddp,ii,1:nut)=utwiss(mfitddp,ii,1:nut)+dp(ii)
              optstat(ii)%over=.true.
              optstat(ii)%stabx=.false.
              optstat(ii)%staby=.false.
              optstat(ii)%stabz=.false.
              optstat(ii)%tracex=optstat(i2)%tracex
              optstat(ii)%tracey=optstat(i2)%tracey
              optstat(ii)%tracez=optstat(i2)%tracez
            else
              if(beg)then
                twiss(ibegin,1,1:ntfun)
     $               =utwiss(1:ntfun,ii,itwissp(ibegin))
              else
                twiss(1,1,:)=utwiss(:,0,1)
                if(inicond)then
                  if(uini(mfitbx,ii) .gt. 0.d0)then
                    twiss(1,1,:)=uini(:,ii)
                  endif
                  twiss(1,1,mfitdx:mfitddp)=
     $                 utwiss(mfitdx:mfitddp,0,1)+
     $                 uini(mfitdx:mfitddp,ii)
                else
                  if(fam)then
                    twiss(1,1,mfitdx:mfitdpy )=
     $                   utwiss(mfitdx:mfitdpy ,i2,1)+dfam(1:4,ii)
                  else
c                    call tgetphysdispu(utwiss(1,i2,1),physd)
c                    physd1=(utwiss(mfitdx:mfitdpy,i2,1)
c     $                     -utwiss(mfitdx:mfitdpy,i3,1))/(dp(i2)-dp(i3))
c                    do i=1,4
c                      if(abs(physd(i)) .gt. abs(physd1(i)))then
c                        physd(i)=physd1(i)
c                      endif
c                    enddo
                    twiss(1,1,mfitdx:mfitdpy)=
     $                   utwiss(mfitdx:mfitdpy,i2,1)
c     $                   +(dp(ii)-dp(i2))*physd
c                    if(ii .eq. nfr)then
c                      write(*,'(a,1p10g12.4)')'tffscalc ',
c     $                     twiss(1,1,mfitdx:mfitdpy),
c     $                     utwiss(mfitex:mfitepy,i2,1),dp(ii),dp(i2)
c                    endif
                  endif
                  twiss(1,1,mfitdz )=utwiss(mfitdz ,i2,1)
                  twiss(1,1,mfitddp)=twiss(1,0,mfitddp)+dp(ii)
                endif
                twiss(1,1,mfitnx)=0.d0
                twiss(1,1,mfitny)=0.d0
                if(fbound%lb .gt. 1)then
                  twiss(fbound%lb,1,1:ntfun)=twiss(1,1,1:ntfun)
                endif
              endif
              call qcell1(ibound,1,optstat(ii),fam,chgini,lout)
              call tffssetutwiss(ii,nlat,fbound,beg,.true.,.true.)
            endif
            if(cell)then
              anuxih=aint(twiss(nlat,1,mfitnx)/pi)
              anuyih=aint(twiss(nlat,1,mfitny)/pi)
              anuxi=aint(twiss(nlat,1,mfitnx)/pi2)
              anuyi=aint(twiss(nlat,1,mfitny)/pi2)
              anusumi=aint((twiss(nlat,1,mfitnx)
     $             +twiss(nlat,1,mfitny))/pi2)
              anudiffi=tfloor((twiss(nlat,1,mfitnx)
     $             -twiss(nlat,1,mfitny))/pi2)
c              anudiffi=twiss(nlat,1,mfitnx)/pi2-
c     $             aint(twiss(nlat,1,mfitnx)/pi2)-
c     $             twiss(nlat,1,mfitny)/pi2+
c     $             aint(twiss(nlat,1,mfitny)/pi2)
c              write(*,*)'tffscalc ',anudiffi,anudiff0
              optstat(ii)%stabx=optstat(ii)%stabx .and. (fam .or.
     $             (.not. intres .or. anuxi .eq. anux0) .and.
     $             (.not. halfres .or. anuxih .eq. anux0h) .and.
     $             (.not. sumres .or. anusumi .eq. anusum0) .and.
     $             (.not. diffres .or. anudiffi .eq. anudiff0))
              optstat(ii)%staby=optstat(ii)%staby .and. (fam .or.
     $             (.not. intres .or. anuyi .eq. anuy0) .and.
     $             (.not. halfres .or. anuyih .eq. anuy0h) .and.
     $             (.not. sumres .or. anusumi .eq. anusum0) .and.
     $             (.not. diffres .or. anudiffi .eq. anudiff0))
            endif
          enddo
          if(ipr .eq. -1 .and. .not. fam .and. idir .eq. 1)then
            idir=-1
            ifb=-1
            ife=-nfr
            go to 2
          endif
          if(.not. fam .and. nfam .gt. nfr)then
            fam=.true.
            ifb=nfam1
            ife=nfam
            idir=1
            go to 1
          endif
          if(ipr .gt. 0)then
            irw=0
            do while(irw .ne. ipr)
              irw=waitpid(-1,isw)
            enddo
            if(isw .ne. 0)then
              call termes(lfno,
     1             '?Error in parallel process.',' ')
            endif
            do i=nfam1,nfam
              if(i .gt. 0 .and. i .le. nfr .or.
     $             kfam(i) .ne. 0 .and. jfam(i) .ge. 0)then
                jb=iutm+(i+nfam)*4
                optstat(i)%stabx=ilist(1,jb+1)
                optstat(i)%staby=ilist(1,jb+2)
                optstat(i)%tracex=rlist(jb+3)
                optstat(i)%tracey=rlist(jb+4)
              endif
            enddo
          elseif(ipr .eq. 0)then
            do i=nfam1,nfam
              if(i .gt. 0 .and. i .le. nfr .or.
     $             kfam(i) .ne. 0 .and. jfam(i) .ge. 0)then
                jb=iutm+(i+nfam)*4
                ilist(1,jb+1)=optstat(i)%stabx
                ilist(1,jb+2)=optstat(i)%staby
                rlist(jb+3)=optstat(i)%tracex
                rlist(jb+4)=optstat(i)%tracey
              endif
            enddo
            stop
          endif
          if(ipr .gt. 0)then
            call tfreeshared(iutm)
          endif
        endif
      endif
      call tdfun(iqcol,lfp,nqcola,nqcola1,kdp,df,error)
      if(error)then
        call termes(lfno,
     1         '?Too many fit conditions.',' ')
        return
      endif
      if(wcal)then
        iter=1
        zcal=.false.
        do i=1,nvar
          kt=idtypec(nelvx(nvevx(i)%ivarele)%klp)
          if(kt .ne. 6 .and. kt .ne. 8 .and. kt .ne. 10
     $         .and. kt .ne. 12)then
            zcal=.true.
            exit
          endif
        enddo
        if(fitflg)then
          if(nvar .le. 0)then
            call termes(lfno,'?No variable.',' ')
            error=.true.
          endif
          if(.not. cell .and. .not. geomet)then
            do i=ibegin,nlat-1
              ii=icomp(i)
              ie=iele1(ii)
              ie1=iele1(i)
              do j=1,nvar
                iv=nvevx(j)%ivvar
                if(iv .eq. nelvx(ie)%ival .and. nvevx(j)%ivarele .eq. ie
     $               .and. (nvevx(j)%ivcomp .eq. 0 .or.
     $               nvevx(j)%ivcomp .eq. ii))then
                  ibegin=i
                  go to 1023
                elseif(iv .ne. nelvx(ie)%ival .and.
     $                 nvevx(j)%ivarele .eq. ie1
     $                 .and. (nvevx(j)%ivcomp .eq. 0 .or.
     $                 nvevx(j)%ivcomp .eq. i))then
                  ibegin=i
                  go to 1023
                endif
                if(nvevx(j)%ivarele .gt. ie)then
                  exit
                endif
              enddo
            enddo
            ibegin=nlat
          endif
        endif
1023    etamax=1.d-2
        if(cell)then
          maxf=fbound%le
        else
          maxf=fbound%lb
          do i=1,nfcol
            maxf=max(maxf,
     $           flv%ifitp(flv%kfitp(i)),flv%ifitp1(flv%kfitp(i)))
          enddo
          if(pos(maxf) .le. pos(1))then
            maxf=fbound%le
          endif
        endif
        do l=fbound%lb,maxf
          etamax=max(abs(twiss(l,0,mfitex)),
     $         abs(twiss(l,0,mfitey)),etamax)
        enddo
        avebeta=(pos(maxf)-pos(1))/
     $       max(twiss(maxf,0,mfitnx),twiss(maxf,0,mfitny))
      endif
      call twfit(flv%kfit,
     1     flv%ifitp,flv%kfitp,kdp,nqcola,iqcol,maxf,wcal)
      wcal=.false.
      rw=0.d0
      residual1(nfam1:nfam)=0.d0
      wsum=0.d0
      do i=1,nqcola
        if(kdp(i) .ne. 0)then
          iq=iqcol(i)
          wi=(offmw/2.d0/
     $         sqrt(dble(max(1,abs(flv%mfitp(flv%kfitp(iq)))))))**2
          wsum=wsum+wi
          wiq(i)=wiq(i)*wi**(1.d0/wexponent)
        else
          wsum=wsum+1.d0
        endif
        df(i)=df(i)*wiq(i)
        if(df(i) .ne. 0.d0)then
          drw=min(1.d50,max(1.d-50,abs(df(i))))**wexponent
          rw=rw+drw
          residual1(kdp(i))=residual1(kdp(i))+drw
        endif
      enddo
      r=merge(wsum*(max(rw,1.d-50)/wsum)**(2.d0/wexponent),
     $     0.d0,rw .gt. 0.d0)
      rp=r
      nstab=0
      if(cell)then
        if(rstab .eq. 0.d0)then
          rstab=10.d0
          do while(rstab .lt. r)
            rstab=rstab*10.d0
          enddo
        endif
        cellstab=.true.
        zerores=.true.
        do i=nfam1,nfam
          if(residual1(i) .ne. 0.d0)then
            zerores=.false.
            if(.not. optstat(i)%stabx)then
              nstab=nstab+1
              residual1(i)=residual1(i)+rstab
              r=r+rstab
              cellstab=.false.
            endif
            if(.not. optstat(i)%staby)then
              nstab=nstab+1
              residual1(i)=residual1(i)+rstab
              r=r+rstab
              cellstab=.false.
            endif
          endif
        enddo
        if(zerores)then
          do i=nfam1,nfam
            cellstab=cellstab .and.
     $           optstat(i)%stabx .and. optstat(i)%staby
          enddo
        endif
      else
        do i=nfam1,nfam
          if(.not. optstat(i)%stabx)then
            nstab=nstab+2
            residual1(i)=residual1(i)+20.d0
          endif
        enddo
      endif
      rlist(imr)=r
      rlist(inr)=rp
      rlist(isl)=dble(nstab)
      ifpe=itgetfpe()
      call tclrfpe
      l=itfuplevel()
      kx=tfeeval(dfromk(ktfsymbol+iepilog),.true.,irtc)
      l=itfdownlevel()
      if(irtc .ne. 0)then
        if(irtc .gt. 0)then
          if(ierrorprint .ne. 0)then
            call tfaddmessage(' ',0,lfno)
          endif
          call tclrfpe
          call termes(lfno,'Error in OpticsEpilog.',' ')
        endif
        error=.true.
      endif
c      call tfevals('Print["PROF: ",LINE["PROFILE","Q1"]]',kxx,irtc)
      call tsetfpe(ifpe)
      return
      end associate
      end

      subroutine twfit(kfit,
     1     ifitp,kfitp,kdp,nqcola,iqcol,maxf,wcal)
      use tfstk
      use ffs, only:emx,emy,dpmax,coumin,emminv
      use ffs_pointer
      use ffs_fit
      use ffs_flag, only:cell
      use tffitcode
      use eeval
      implicit none
      integer*4 ,intent(in):: nqcola,maxf,
     $     kfit(*),ifitp(*),kfitp(*),kdp(*),iqcol(nqcola)
      integer*4 i,j,k,iq
      real*8 coum,emxx,emyy,dpm,coup,em
      integer*4 itfuplevel, level,irtc,idp
      character*16 name
      logical*4 ,intent(in):: wcal
      type (sad_descriptor) kx
      type (sad_descriptor) ,save::kfv
      data kfv%k /0/
      type (sad_dlist), pointer , save::klv
      type (sad_rlist), pointer , save::klid
      integer*8 , save:: ifvloc,ifvfun
      real*8 , parameter :: almin=1.d0
      if(kfv%k .eq. 0)then
        kfv=kxadaloc(0,4,klv)
        klv%head=dtfcopy(kxsymbolz('`FitWeight',10))
        ifvloc=ktsalocb(0,'                ',MAXPNAME+8)
        ifvfun=ktsalocb(0,'        ',MAXPNAME)
        klv%body(1)=ktfstring+ifvloc
        klv%body(2)=ktfstring+ifvfun
        klv%dbody(3)=kxraaloc(0,2,klid)
        klv%body(4)=0
      endif
      em=max(emminv,abs(emx)+abs(emy))
      coum=min(1.d0,
     $     max(coumin,0.01d0,
     $     1.d0/(abs(emx/max(emminv,emy))+abs(emy/max(emminv,emx)))))
      coum=coum/(1.d0+coum)
      emxx=max(emx,coum*em)
      emyy=max(emy,coum*em)
      dpm=max(0.001d0,dpmax)
      coup=sqrt(abs(emxx/emyy)+abs(emyy/emxx))
      if(wcal)then
        do i=1,nfcol
          k=kfit(kfitp(i))
          j=ifitp(kfitp(i))
          select case(k)
          case (mfitex,mfitpex)
            wfit(i)=dpm/sqrt(emxx*twiss(j,0,mfitbx))
          case (mfitepx,mfitpepx)
            wfit(i)=dpm*sqrt(twiss(j,0,mfitbx)
     1           /(1.d0+twiss(j,0,mfitax)**2)/emxx)
          case (mfitey,mfitpey)
            wfit(i)=dpm/sqrt(emyy*twiss(j,0,mfitby))
          case (mfitepy,mfitpepy)
            wfit(i)=dpm*sqrt(twiss(j,0,mfitby)
     1           /(1.d0+twiss(j,0,mfitay)**2)/emyy)
          case (mfitr1)
            wfit(i)=coup*sqrt(twiss(j,0,mfitbx)/twiss(j,0,mfitby))
          case (mfitr2)
            wfit(i)=coup/sqrt(twiss(j,0,mfitbx)*twiss(j,0,mfitby))
          case (mfitr3)
            wfit(i)=coup*sqrt(twiss(j,0,mfitbx)*twiss(j,0,mfitby))
          case (mfitr4)
            wfit(i)=coup*sqrt(twiss(j,0,mfitby)/twiss(j,0,mfitbx))
          case (mfitdx)
            wfit(i)=1.d0/sqrt(twiss(j,0,mfitbx)*em)
          case (mfitdpx)
            wfit(i)=sqrt(twiss(j,0,mfitbx)/
     $           (1.d0+twiss(j,0,mfitax)**2)/em)
          case (mfitdy)
            wfit(i)=1.d0/sqrt(twiss(j,0,mfitby)*em)
          case (mfitdpy)
            wfit(i)=sqrt(twiss(j,0,mfitby)/
     $           (1.d0+twiss(j,0,mfitay)**2)/em)
          case (mfitleng)
            wfit(i)=1.d0/(pos(maxf)-pos(1))*
     $           max(twiss(maxf,0,mfitnx),twiss(maxf,0,mfitny))
          case (mfitdz)
            wfit(i)=0.01d0*sqrt(
     $           max(twiss(maxf,0,mfitnx),twiss(maxf,0,mfitny))
     $           /em/max(almin,pos(maxf)-pos(1)))
          case (mfitgx,mfitgy,mfitgz)
            wfit(i)=0.01d0*sqrt(
     $           max(twiss(maxf,0,mfitnx),twiss(maxf,0,mfitny))
     $           /em/max(almin,pos(maxf)-pos(1)))
          case (mfitchi1,mfitchi2,mfitchi3)
            wfit(i)=1.d3
          case default
            wfit(i)=1.d0
          end select
          if(cell .and.
     $         kfitp(i) .gt. nfc0 .and. kfitp(i) .le. nfc0+4)then
            wfit(i)=wfit(i)*0.7d0
          endif
        enddo
      endif
      do iq=1,nqcola
        i=iqcol(iq)
        if(i .gt. 0)then
          k=kfit(kfitp(i))
          j=ifitp(kfitp(i))
          idp=kdp(iq)
          wiq(iq)=wfit(i)
          call elname(j,name)
          call tfpadstr(name,ifvloc+1,len_trim(name))
          ilist(1,ifvloc)=len_trim(name)
          call tfpadstr(nlist(k),ifvfun+1,len_trim(nlist(k)))
          ilist(1,ifvfun)=len_trim(nlist(k))
          klid%rbody(1)=merge(dble(iuid(idp)),dble(kfam(idp)),
     $         inicond)
          klid%rbody(2)=dp(idp)
          klv%rbody(4)=wfit(i)
          call tclrfpe
          level=itfuplevel()
          kx=tfleval(klv,.true.,irtc)
          call tfconnect(kx,irtc)
          if(irtc .ne. 0)then
            if(ierrorprint .ne. 0)then
              call tfaddmessage(' ',2,6)
            endif
            call termes(6,'Error in FitWeight '//
     $           nlist(k)//' at '//name,' ')
          elseif(ktfrealq(kx,wiq(iq)))then
          endif
        else
          wiq(iq)=1.d0
        endif
      enddo
      return
      end

      subroutine tffsbound(fbound)
      use tfstk
      use ffs, only:nlat,ffs_bound
      use ffs_pointer
      use mackw
      implicit none
      type (ffs_bound) ,intent(out):: fbound
      call tffsbound1(1,nlat,fbound)
      return
      end

      subroutine tffsbound1(lb,le,fbound)
      use tfstk
      use ffs, only:nlat,ffs_bound
      use ffs_pointer
      use mackw
      implicit none
      type (ffs_bound) ,intent(out):: fbound
      integer*4 ,intent(in):: lb,le
      integer*4 le1
      real*8 xnlat,offset,tffsmarkoffset
      xnlat=nlat
      offset=tffsmarkoffset(lb)
      if(offset .ne. 0.d0)then
        offset=max(1.d0,min(xnlat,lb+offset))
        fbound%lb=int(offset)
        fbound%fb=offset-fbound%lb
      else
        fbound%lb=lb
        fbound%fb=0.d0
      endif
      le1=le
      if(le .eq. nlat)then
        if(idtypec(nlat-1) .eq. icMARK)then
          le1=le1-1
        else
          fbound%le=le1
          fbound%fe=0.d0
          return
        endif
      endif
      offset=tffsmarkoffset(le1)
      if(offset .ne. 0.d0)then
        offset=max(1.d0,min(xnlat,le1+offset))
        fbound%le=int(offset)
        fbound%fe=offset-fbound%le
      else
        fbound%le=le1
        fbound%fe=0.d0
      endif
      return
      end

      real*8 function tffsmarkoffset(lp)
      use tfstk
      use ffs_pointer
      use mackw
      use tmacro, only:nlat
      implicit none
      type (sad_comp), pointer :: cmp
      integer*4 ,intent(in):: lp
      integer*4 k
      if(lp .ge. nlat)then
        tffsmarkoffset=0.d0
        return
      endif
      call compelc(lp,cmp)
      k=kytbl(kwOFFSET,idtype(cmp%id))
      if(k .gt. 0)then
        tffsmarkoffset=cmp%value(k)
        if(tffsmarkoffset .ne. 0.d0)then
          tffsmarkoffset=(tffsmarkoffset-.5d0)*direlc(lp)+.5d0
        endif
      else
        tffsmarkoffset=0
      endif
      return
      end

      real*8 function tffselmoffset(l)
      use tfstk
      use ffs, only:nlat
      use ffs_pointer
      use mackw
      use tfcsi, only:icslfno
      implicit none
      integer*4 ,intent(in):: l
      integer*4 lm,nm,lx,nmmax
      parameter (nmmax=256)
      real*8 offset,xp,xe,tffsmarkoffset
      nm=0
      xp=l
      if(l .ne. nlat .and. kytbl(kwOFFSET,idtypec(l)) .ne. 0)then
        xe=nlat
        lm=l
        do
          offset=tffsmarkoffset(lm)
          if(offset .ne. 0.d0)then
            xp=offset+lm
            if(xp .ge. 1.d0 .and. xp .le. xe)then
              lx=int(xp)
              if(idtypec(lx) .eq. icMARK)then
                nm=nm+1
                if(nm .lt. nmmax)then
                  lm=lx
                  cycle
                else
                  call termes(icslfno(),
     $                 '?Recursive OFFSET in',pnamec(l))
                endif
              endif
            endif
          endif
          exit
        enddo
      endif
      tffselmoffset=xp
      return
      end

      subroutine tffssetutwiss(idp,nlat,fbound,beg,begin,end)
      use tfstk
      use ffs, only:ffs_bound
      use ffs_pointer
      use tffitcode
      use mackw
      implicit none
      type (ffs_bound) ,intent(in):: fbound
      integer*4 ,intent(in):: nlat,idp
      integer*4 jdp,j,jp,le1
      logical*4 ,intent(in):: beg,begin,end
      jdp=min(1,abs(idp))
      do concurrent (j=fbound%lb:fbound%le)
        jp=itwissp(j)
        if(jp .gt. 0)then
          utwiss(:,idp,jp)=twiss(j,jdp,:)
        endif
      enddo
      jp=itwissp(1)
      if(begin)then
        if(jp .gt. 0 .and. .not. beg)then
          twiss(1,jdp,:)=twiss(fbound%lb,jdp,:)
          utwiss(:,idp,jp)=twiss(fbound%lb,jdp,:)
        endif
      endif
      if(end)then
        if(idtypec(nlat-1) .eq. icMARK)then
          le1=merge(fbound%le,fbound%le+1,fbound%fe .eq. 0.d0)
          twiss(nlat-1,jdp,:)=twiss(le1,jdp,:)
          twiss(nlat,jdp,:)=twiss(le1,jdp,:)
          jp=itwissp(nlat-1)
          if(jp .gt. 0)then
            utwiss(:,idp,jp)=twiss(le1,jdp,:)
          endif
          jp=itwissp(nlat)
          if(jp .gt. 0)then
            utwiss(:,idp,jp)=twiss(le1,jdp,:)
          endif
        endif
      endif
      return
      end