!***********************************************************************
!                                                                      *
      PROGRAM BIOSCL
!                                                                      *
!     This program calculates the transition parameters for a          *
!     transition between an initial and a final state                  *
!     The program assumes that the radial orbitals of the initial      *
!     and final state have been transformed by the BIOTRA program      *
!     as to become biorthonormal, in which case the normal Racah       *
!     algebra can be used.                                             *
!                                                                      *
!     Written by Per Jonsson,   Department of Computer Science         *
!                             Vanderbilt University, USA               *
!                                                                      *
!     Modified by Gediminas Gaigalas for new spin-angular integration  *
!     and for reducing usage of CPU memory.        NIST, October 2017  *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:35:54   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE default_C
      USE debug_C, ONLY: LDBPR, CUTOFF
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE getyn_I
      USE setmc_I
      USE setcon_I
      USE fname_I
      USE mrgcsl_I
      USE setcslm_I
      USE getosd_I
      USE strsum_I
      USE factt_I
      USE oscl_I
      USE mpi_C
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NTEST,NCOUNT1,ILBL,lenperm,lentmp, iii
      LOGICAL :: YES
      CHARACTER, DIMENSION(2) :: NAME*24
      CHARACTER, DIMENSION(2) :: FULLNAME*128
      CHARACTER(LEN=3)  ::  idstring
      CHARACTER(LEN=128) :: ISOFILE,startdir,permdir,tmpdir
!-----------------------------------------------
!
!=======================================================================
!  Start mpi --- get processor info: myid, nprocs, host name; and print
!=======================================================================
      CALL startmpi2 (myid, nprocs, host, lenhost, ncount1,           &
                      startdir, permdir, tmpdir, 'RTRANSITION_MPI')
      WRITE (idstring, '(I3.3)') myid
      print*, tmpdir , ' = tmpdir'

      lenperm = LEN_TRIM (permdir)
      lentmp = LEN_TRIM (tmpdir)

!=======================================================================
      ISOFILE = trim(startdir)//'/isodata'
      NTEST = 1001

      IF (myid .EQ. 0) THEN
         WRITE (6, *)
         WRITE (6, *) ' Default settings?'
         YES = GETYN()
         WRITE (6, *)
         IF (YES) THEN
            NDEF = 0
            NDUMP = 1
         ELSE
            NDEF = 1
            WRITE (6, *) ' Dump angular data to file?'
            YES = GETYN()
            IF (YES) THEN
               NDUMP = 1
            ELSE
               NDUMP = 0
             ENDIF
         ENDIF
         WRITE (6, *)
         WRITE (6, *) ' Input from a CI calculation?'
         YES = GETYN()
         WRITE (6, *)
         IF (YES) THEN
            INPCI = 0
         ELSE
            INPCI = 1
         ENDIF
      ENDIF   !myid=0
      CALL MPI_Bcast (NDEF,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
      CALL MPI_Bcast (NDUMP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
      CALL MPI_Bcast (INPCI,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
!Rasa -- start
!GG      LDBPR = .FALSE.
!      WRITE (6, *) ' Generate debug output?'
!      YES = GETYN()
!      WRITE (6, *)
!      IF (YES) THEN
!         LDBPR(18) = .TRUE.
!         WRITE (6, *) ' Enter the cutoff'
!         READ (5, *) CUTOFF
!      ENDIF
!Rasa -- end
!
!   Perform machine- and installation-dependent setup
!
      CALL SETMC
!
!   Set up the physical constants
!
      CALL SETCON
!
!   Obtain the names of the initial and final state files
!
      IF (myid .EQ. 0) CALL FNAME(NAME)
      CALL MPI_Bcast (NAME,48,MPI_CHARACTER,0,MPI_COMM_WORLD,ierr)
      FULLNAME(1) = TRIM(startdir) // '/' // TRIM(NAME(1))
      FULLNAME(2) = TRIM(startdir) // '/' // TRIM(NAME(2))
!
!   Open, check, load data from, and close, the initial and final state
!   .csl  files. These files are then merged to one file.
!
!cjb print FULLNAME1= FULLNAME2=
      IF (myid .EQ. 0) then
        print*,"FULLNAME1=",FULLNAME(1)
        print*,"FULLNAME2=",FULLNAME(2)
      end if

      CALL MRGCSL (FULLNAME)
!
!   Open, check, load data from, and close, the merged .csl  file
!
      CALL SETCSLM
!
!   Read mixing coefficients
!
!      CALL READMIX(NAME,INPCI)
!
!   Test mixing coefficients
!
!      IF (NTEST.GT.1000) CALL TESTMIX
!
!   Open, check, load data from, and close the .iso file
!
      CALL SETISO(ISOFILE)

!
!   Get the remaining information
!
      CALL GETOSD (FULLNAME)
!
!   Open and append a summary of the inputs to the  .sum  file
!
      if (myid == 0) then
          iii = len_trim(startdir)
          call sys_chdir(trim(startdir),iii,ierr)
          if (ierr.ne.0) then
              print *, "error changing dir!"
              call exit(1)
          endif
          CALL STRSUM(NAME,INPCI,ILBL)
          iii = len_trim(tmpdir)
          call sys_chdir(trim(tmpdir)//'/'//idstring,iii+4,ierr)
          if (ierr.ne.0) then
              print *, "Error changing dir!"
              call exit(1)
          endif
      endif  !myid = 0
!
!   Set up the table of logarithms of factorials
!
      CALL FACTT
!
!   Proceed with the transition calculation
!
      CALL OSCL (NAME,FULLNAME,tmpdir,startdir,idstring)
!
!   Print completion message
!
      IF (myid .EQ. 0) THEN
          PRINT *
          PRINT *, 'RTRANSITION_MPI: Execution complete.'
      ENDIF
!=======================================================================
!  Execution finished; Statistics output
!=======================================================================

      CALL stopmpi2 (myid, nprocs, host, lenhost,                     &
                           ncount1, 'RTRANSITION_MPI')
!=======================================================================
!
      STOP
      END PROGRAM BIOSCL


*dk,try2to0b
      subroutine try2to0b(iary,ntet,nflips,nflipsb,it2,
     *                    npoints,ntets)
C
C ######################################################################
C
C     PURPOSE -
C
C        This routine checks a list of tets for the 2-to-0 flip.
C        Flips across material interfaces are considered.
C
C
C     INPUT ARGUMENTS -
C
C        ipiary   - pointer to the array of tets to check.
C                   note iary is now an array of itets
C        ntet    - the number of tets in the list
C
C     OUTPUT ARGUMENTS -
C
C        flips    - the number of nonboundary flips that have occurred.
C        nflipsb  - the number of boundary flips that have occurred.
C        it2      - the second tet that is removed.
C
C     CHANGE HISTORY -
C
C        $Log: try2to0b.f,v $
C        Revision 2.00  2007/11/09 20:04:05  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.9   05 Jan 2001 12:57:26   dcg
CPVCS    use dble in place of float so as not to lose digits
CPVCS
CPVCS       Rev 1.8   Mon Apr 14 17:04:56 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.7   Thu Oct 17 14:05:02 1996   dcg
CPVCS    declare isubname to be type character
CPVCS
CPVCS       Rev 1.6   Tue Oct 01 08:55:20 1996   dcg
CPVCS    move memory manager calls
CPVCS
CPVCS       Rev 1.5   Tue Apr 16 14:34:54 1996   dcg
CPVCS    try2to2b.f try2to4r.f try4to4x.f trymtonr.f
CPVCS    replace pointer ipitets with array itets
CPVCS
CPVCS       Rev 1.4   Tue Mar 05 14:17:44 1996   dcg
CPVCS    remove icn1 int1
CPVCS
CPVCS       Rev 1.3   12/02/94 15:07:02   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:49:30   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:55:18   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:19:30   pvcs
CPVCS    Original version.
C
C ######################################################################
C
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"

C arguments (iary,ntet,nflips,nflipsb,it2,npoints,ntets)
      integer iary(*)
      integer ntet,nflips,nflipsb,it2,npoints,ntets

C
      integer nmulti
      parameter (nmulti = 200)
      integer ichain0(nmulti),imt0(nmulti)

      pointer (ipint1, int1)
      integer int1(*)

      integer ierror,length,icmotype,lenimt1,lenitp1,
     *        lenitetclr,ier,lenitet,lenjtet,i,it,imtx,j,k,
     *        jtemp,ict,ipar,index,kpt2,ifpos,ierr

      character*32 isubname
C
C ######################################################################
C BEGIN begin
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      isubname='try2to0b'
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('imt1',cmo,ipimt1,lenimt1,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,lenitp1,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,lenitetclr,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
C
      endif
C
      call mmgetblk('int1',isubname,ipint1,npoints,1,ierror)
      call unpacktp('intrface','set',npoints,ipitp1,ipint1,ierror)
C
C     ******************************************************************
      nflips=0
      nflipsb=0
      do 100 i=1,ntet
         it=iary(i)
         if(it.eq.0.or.itet(1,it).lt.0) goto 100
         imtx=imt1(itet(1,it))
         do 90 j=1,4
            if(jtet(j,it).lt.mbndry) then
               if(itet1(jtet(j,it)).eq.itet(j,it)) then
                  it2=0.25*dble(jtet(j,it))+0.9
                  call flip2to0(it,it2,
     *                          npoints,ntets)
                  iary(i)=0
                  do 10 k=i+1,ntet
                     if(iary(k).eq.it2) iary(k)=0
 10               continue
                  nflips=nflips+1
                  goto 100
               endif
            elseif (jtet(j,it) .gt. mbndry) then
               jtemp=jtet(j,it)-mbndry
               if (int1(itet1(jtemp)) .eq. 0) goto 90
               call getchain(itet1(jtemp),ichain0,imt0,nmulti,ict,ipar)
               index=0
               do 20 k=1,ict
                  if (imt0(k).eq.imtx) then
                     index=k
                     goto 50
                  endif
 20            continue
               if (index.eq.0) goto 90
 50            continue
               kpt2=ichain0(index)
               if (itet(j,it) .eq. kpt2) then
                  it2=0.25*dble(jtemp)+0.9
                  ifpos=j
                  call flp2to0b(it,ifpos,it2,
     *                          npoints,ntets)
                  iary(i)=0
                  do 60 k=i+1,ntet
                     if (iary(k) .eq. it2) iary(k)=0
 60               continue
                  nflipsb=nflipsb+1
                  goto 100
               endif
            endif
C
 90      continue
 100   continue
C
      goto 9999
 9999 continue
      call mmrelprt (isubname,ierr)
      return
      end


module temporal

!DO NOT FIX THESE WARNINGS - THEY ARE FOR UNUSED VARIABLES THAT MAY BE LEVERAGED
!IN LATER RELEASES
!/home/zettergm/zettergmdata/GEMINI/temporal/temporal.f90:65:0: warning: unused
!parameter ‘ns’ [-Wunused-parameter]
!   pure subroutine
!dt_calc(tcfl,ns,Ts,vs1,vs2,vs3,B1,B2,B3,dx1i,dx2i,dx3i,potsolve,cour1,cour2,cour3,dt) ^
!/home/zettergm/zettergmdata/GEMINI/temporal/temporal.f90:65:0: warning: unused parameter ‘b1’ [-Wunused-parameter]
!/home/zettergm/zettergmdata/GEMINI/temporal/temporal.f90:65:0: warning: unused parameter ‘b2’ [-Wunused-parameter]
!/home/zettergm/zettergmdata/GEMINI/temporal/temporal.f90:65:0: warning: unused parameter ‘b3’ [-Wunused-parameter]
!/home/zettergm/zettergmdata/GEMINI/temporal/temporal.f90:65:0: warning: unused parameter ‘potsolve’ [-Wunused-parameter]

use phys_consts, only:  kB,mu0,ms,lsp,pi, wp, debug
use mpimod, only: mpi_realprec, tag=>mpi_tag, lid, myid, MPI_COMM_WORLD,MPI_STATUS_IGNORE
use mesh, only:  curvmesh
use config, only: gemini_cfg

implicit none (type, external)

private
public :: dt_comm

external :: mpi_send, mpi_recv

contains

subroutine dt_comm(t,tout,tglowout,cfg,ns,Ts,vs1,vs2,vs3,B1,B2,B3,x,dt)

real(wp), intent(in) :: t,tout,tglowout
type(gemini_cfg), intent(in) :: cfg
real(wp), dimension(-1:,-1:,-1:,:), intent(in) :: ns,Ts,vs1,vs2,vs3
real(wp),  dimension(-1:,-1:,-1:), intent(in) :: B1,B2,B3
type(curvmesh), intent(in) :: x
real(wp), intent(out) :: dt

real(wp), dimension(lsp) :: cour1,cour2,cour3
integer :: iid,isp, ierr
real(wp) :: dttmp

call dt_calc(cfg%tcfl,ns,Ts,vs1,vs2,vs3,B1,B2,B3,x%dl1i,x%dl2i,x%dl3i,cfg%potsolve,cour1,cour2,cour3,dt)

if (myid/=0) then
  call mpi_send(dt,1,mpi_realprec,0,tag%dt,MPI_COMM_WORLD,ierr)
  !! send what I think dt should be
  call mpi_recv(dt,1,mpi_realprec,0,tag%dt,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  !! receive roots decision
else
  !> FIGURE OUT GLOBAL DT REQUIRED FOR STABILITY
  do iid=1,lid-1
    call mpi_recv(dttmp,1,mpi_realprec,iid,tag%dt,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)

    if (dttmp < dt) dt=dttmp
  end do

  !CHECK WHETHER WE'D OVERSTEP OUR TARGET OUTPUT TIME
  !GLOW OUTPUT HAS PRIORITY SINCE IT WILL OUTPUT MORE OFTEN
  if ((cfg%flagglow/=0).and.(t+dt>tglowout)) then
    dt=tglowout-t
    print *, 'GLOW is throttling dt...'
  end if

  if (t+dt>tout) then
    dt=tout-t
    if (debug) print *, 'Slowing down for an output...'
  end if

  !! DON'T ALLOW ZERO DT
  dt = max(dt, 1e-6_wp)

  !! SEND GLOBAL DT TO ALL WORKERS
  do iid=1,lid-1
    call mpi_send(dt,1,mpi_realprec,iid,tag%dt,MPI_COMM_WORLD,ierr)
  end do

  if (debug) then
    print *, 'dt figured to be:  ',dt
    print *, 'x1,x2,x3 courant numbers (root process only!):  '
    do isp=1,lsp
      print '(a,f4.2,a,f4.2,a,f4.2)', '    ',cour1(isp),', ',cour2(isp),', ',cour3(isp)
      !! these are roots courant numbers
    end do
    print *, 'Min and max density:  ',minval(pack(ns(:,:,:,7),.true.)),maxval(pack(ns(:,:,:,7),.true.))
  endif
end if

end subroutine dt_comm

pure subroutine dt_calc(tcfl,ns,Ts,vs1,vs2,vs3,B1,B2,B3,dx1i,dx2i,dx3i,potsolve,cour1,cour2,cour3,dt)

!------------------------------------------------------------
!-------COMPUTE TIME STEP SUCH THAT STABILITY CONDITION IS
!-------SATISFIED.  NOTE THAT THE DIFFERENTIALS ARE ASSUMED
!-------TO HAVE UNITS OF DISTANCE, SO THEY MUST IMPLICITLY
!-------INCLUDE THE METRIC FACTORS.
!------------------------------------------------------------

real(wp), intent(in) :: tcfl
real(wp), dimension(-1:,-1:,-1:,:), intent(in) :: ns,Ts,vs1,vs2,vs3
real(wp),  dimension(-1:,-1:,-1:), intent(in) :: B1,B2,B3
real(wp), dimension(:,:,:), intent(in) :: dx1i
real(wp), dimension(:,:,:), intent(in) :: dx2i
real(wp), dimension(:,:,:), intent(in) :: dx3i
integer, intent(in) :: potsolve
real(wp), dimension(lsp), intent(out) :: cour1,cour2,cour3
real(wp), intent(out) :: dt

real(wp), dimension(lsp) :: gridrate1,gridrate2,gridrate3
real(wp) :: vsnd
real(wp) :: rhom,Bmag,vA
integer :: lx1,lx2,lx3,ix1,ix2,ix3,isp

lx1=size(Ts,1)-4
lx2=size(Ts,2)-4
lx3=size(Ts,3)-4

gridrate1=0._wp
gridrate2=0._wp
gridrate3=0._wp

!EVALUATE TIME STEP AGAINST LOCAL SOUND SPEED AND ADVECTION
do isp=1,lsp
  do ix3=1,lx3
    do ix2=1,lx2
      do ix1=1,lx1
        if (isp<lsp) then
          vsnd=sqrt(kB*Ts(ix1,ix2,ix3,isp)/ms(isp)+5._wp/3._wp*kB*Ts(ix1,ix2,ix3,lsp)/ms(isp))
        else
          vsnd=0._wp
        end if

        gridrate1(isp)=max((vsnd+abs(vs1(ix1,ix2,ix3,isp)))/dx1i(ix1,ix2,ix3),gridrate1(isp))
        gridrate2(isp)=max(abs(vs2(ix1,ix2,ix3,isp))/dx2i(ix1,ix2,ix3),gridrate2(isp))
        gridrate3(isp)=max(abs(vs3(ix1,ix2,ix3,isp))/dx3i(ix1,ix2,ix3),gridrate3(isp))
      end do
    end do
  end do
end do

!    !CHECK GRIDRATE MAX AGAINST LOCAL ALFVEN SPEED (IF THIS SIMULATION IS INDUCTIVE)
!    !NOTE THAT THIS SHOULD REALLY INCLUDE MAGNETOSONIC (FAST) MODES IN GRIDRATE DETERMINATION
!    !AS OF 2/10/2016 THIS CODE IS NOT USED AT ALL, BUT IS KEPT FOR FUTURE DEVELOPMENT
!    if (potsolve == 2) then
!      do ix3=1,lx3
!        do ix2=1,lx2
!          do ix1=1,lx1
!            rhom=0._wp
!            do isp=1,lsp
!              rhom=rhom+ms(isp)*ns(ix1,ix2,ix3,isp)
!            end do
!            Bmag=sqrt(B1(ix1,ix2,ix3)**2+B2(ix1,ix2,ix3)**2+B3(ix1,ix2,ix3)**2)
!
!            vA=Bmag/sqrt(rhom*mu0)
!
!            do isp=1,lsp
!              gridrate1(isp)=max(vA/dx1i(ix1),gridrate1(isp))
!              gridrate2(isp)=max(vA/dx2i(ix2),gridrate2(isp))
!              gridrate3(isp)=max(vA/dx3i(ix3),gridrate3(isp))
!            end do
!          end do
!        end do
!      end do
!    end if

!ENFORCE A MINIMUM VALUE FOR THE GRIDRATE (WHICH IS CFL/DT, GRID POINTS PER SECOND)
gridrate1=max(gridrate1, 1e-10_wp)
gridrate2=max(gridrate2, 1e-10_wp)
gridrate3=max(gridrate3, 1e-10_wp)

dt=tcfl*min(minval(1._wp/gridrate1),minval(1._wp/gridrate2),minval(1._wp/gridrate3))
cour1=dt*gridrate1
cour2=dt*gridrate2
cour3=dt*gridrate3
end subroutine dt_calc

end module temporal


      subroutine evdata(aadh,aadhh,aadhv,aaphi,abdh,abdhh,abdhv,
     $ abdot,abdoth,abdotv,adadhh,adadhv,adbdhh,adbdhv,adbdth,adbdtv,
     $ adh,adhfe,adhh,adhv,adhfs,adhfsd,advfe,advfs,advfsd,afcnst,
     $ al10,amu,aslm,aphi,aprehw,apresg,apresh,apx,avcnst,axhfe,
     $ axhfs,axhfsd,axlke,axlks,axlksd,axvfe,axvfs,axvfsd,bdh,bdhh,
     $ bdhv,bdot,bdoth,bdotv,dadhh,dadhv,dbdhh,dbdhv,dbdth,dbdtv,
     $ dhfe,dhfs,dhfsd,dvfe,dvfs,dvfsd,ehfac,farad,iapxmx,iktmax,
     $ iopg,iopt,ipbtmx,ipch,ipchmx,ipcv,ipcvmx,ixrn1,ixrn2,jpfcmx,
     $ jptffl,jsol,narxmx,narxt,narxth,ncmpr,nmut,nmutmx,nopgmx,
     $ noptmx,noutpt,nptmax,nslt,nsltmx,nst,nstmax,ntpr,ntprmx,nttyo,
     $ nxt,nxtmax,pmu,prehw,presg,presh,press,pslamn,rconst,rcnstv,
     $ rtcnst,tempc,tempk,uphase,uspec,wfac,xhfe,xhfs,xhfsd,xlke,xlks,
     $ xlksd,xvfe,xvfs,xvfsd)
c
c     This subroutine evaluates thermodynamic properties as a function
c     of temperature and the standard grid pressure. Pressure
c     corrections are made by EQLIB/pcorrx.f.
c
c     This subroutine is called by:
c
c       EQ3NR/eq3nr.f
c       EQ6/eq6.f
c       EQ6/tpadv.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer iapxmx,iktmax,ipbtmx,ipchmx,ipcvmx,jpfcmx,narxmx,nmutmx,
     $ nopgmx,noptmx,nptmax,nsltmx,nstmax,ntprmx,nxtmax
c
      integer noutpt,nttyo
c
      integer iopg(nopgmx),iopt(noptmx),jsol(nxtmax),narxt(ntprmx),
     $ narxth(2),ncmpr(2,nptmax)
c
      integer ipch,ipcv,ixrn1,ixrn2,jptffl,nmut,nslt,nst,ntpr,nxt
c
      character*48 uspec(nstmax)
      character*24 uphase(nptmax)
c
      real*8 aadh(narxmx,ntprmx),aadhh(narxmx,ntprmx),
     $ aadhv(narxmx,ntprmx),aaphi(narxmx,ntprmx),
     $ abdh(narxmx,ntprmx),abdhh(narxmx,ntprmx),abdhv(narxmx,ntprmx),
     $ abdot(narxmx,ntprmx),abdoth(narxmx,ntprmx),abdotv(narxmx,ntprmx),
     $ adadhh(narxmx,ntprmx,ipchmx),adadhv(narxmx,ntprmx,ipcvmx),
     $ adbdhh(narxmx,ntprmx,ipchmx),adbdhv(narxmx,ntprmx,ipcvmx),
     $ adbdth(narxmx,ntprmx,ipchmx),adbdtv(narxmx,ntprmx,ipcvmx),
     $ adhfe(narxmx,ntprmx,ipchmx),adhfs(narxmx,ntprmx,ipchmx,nstmax),
     $ adhfsd(narxmx,ntprmx,ipchmx,nstmax),advfe(narxmx,ntprmx,ipcvmx),
     $ advfs(narxmx,ntprmx,ipcvmx,nstmax),
     $ advfsd(narxmx,ntprmx,ipcvmx,nstmax),
     $ aprehw(narxmx,ntprmx),apresg(narxmx,ntprmx),apresh(5,2),
     $ axhfe(narxmx,ntprmx),axhfs(narxmx,ntprmx,nstmax),
     $ axhfsd(narxmx,ntprmx,nstmax),axlke(narxmx,ntprmx),
     $ axlks(narxmx,ntprmx,nstmax),axlksd(narxmx,ntprmx,nstmax),
     $ axvfe(narxmx,ntprmx),axvfs(narxmx,ntprmx,nstmax),
     $ axvfsd(narxmx,ntprmx,nstmax)
c
      real*8 dadhh(ipchmx),dadhv(ipcvmx),dbdhh(ipchmx),dbdhv(ipcvmx),
     $ dbdth(ipchmx),dbdtv(ipcvmx),dhfe(ipchmx),dhfs(ipchmx,nstmax),
     $ dhfsd(ipchmx,nstmax),dvfe(ipcvmx),dvfs(ipcvmx,nstmax),
     $ dvfsd(ipcvmx,nstmax),xhfs(nstmax),xhfsd(nstmax),xlks(nstmax),
     $ xlksd(nstmax),xvfs(nstmax),xvfsd(nstmax)
c
      real*8 adh,adhh,adhv,aphi,bdh,bdhh,bdhv,bdot,bdoth,bdotv,
     $ prehw,presg,presh,press,xhfe,xlke,xvfe
c
      real*8 amu(jpfcmx,nmutmx),aslm(jpfcmx,0:ipbtmx,nsltmx),
     $ pmu(nmutmx),pslamn(0:ipbtmx,nsltmx)
c
      real*8 apx(iapxmx,nxtmax),wfac(iktmax,nxtmax)
c
      real*8 afcnst,al10,avcnst,ehfac,farad,rconst,rcnstv,rtcnst,
     $ tempc,tempk
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ipc,ntprh
c
      real*8 prop
c
c-----------------------------------------------------------------------
c
c     Compute temperature dependent constants.
c
      rtcnst = 0.001*rconst*tempk
      afcnst = al10*rtcnst
      avcnst = al10*rcnstv*tempk
      ehfac = (al10*rconst*tempk)/farad
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the standard grid pressure.
c
c     Calling sequence substitutions:
c       apresg for arr
c       presg for prop
c
      call evdat2(apresg,narxmx,narxt,ntpr,ntprmx,presg,tempc)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the 1.013-bar/steam-saturation curve pressure at the
c     initial temperature.
c
      if (tempc .le. 100.) then
        ntprh = 1
      else
        ntprh = 2
      endif
c
c     Calling sequence substitutions:
c       apresh for arr
c       5 for narxmx
c       narxth for narxt
c       ntprh for ntpr
c       2 for ntprmx
c       presh for prop
c
      call evdat2(apresh,5,narxth,ntprh,2,presh,tempc)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ipcv .ge. 0) then
c
c       Compute the half-width of the recommended pressure envelope.
c
c       Calling sequence substitutions:
c         aprehw for arr
c         prehw for prop
c
        call evdat2(aprehw,narxmx,narxt,ntpr,ntprmx,prehw,tempc)
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (iopg(1) .le. 0) then
c
c       Davies equation or B-dot equation.
c
c       Compute the Debye-Huckel A(gamma,10) parameter.
c
c       Calling sequence substitutions:
c         aadh for arr
c         adh for prop
c
        call evdat2(aadh,narxmx,narxt,ntpr,ntprmx,adh,tempc)
c
        aphi = adh*al10/3.
      endif
c
      if (iopg(1) .eq. 1) then
c
c       Pitzer's equations.
c
c       Compute the Debye-Huckel A(phi) parameter.
c
c       Calling sequence substitutions:
c         aaphi for arr
c         aphi for prop
c
        call evdat2(aaphi,narxmx,narxt,ntpr,ntprmx,aphi,tempc)
        adh= 3.*aphi/al10
      endif
c
      if (iopg(1) .eq. 2) then
c
c       HC + DH equations.
c
c       Compute the Debye-Huckel A(gamma,10) parameter.
c
c       Calling sequence substitutions:
c         aadh for arr
c         adh for prop
c
        call evdat2(aadh,narxmx,narxt,ntpr,ntprmx,adh,tempc)
c
        aphi = adh*al10/3.
      endif
c
      if (ipch .ge. 0) then
c
c       Compute the Debye-Huckel A(H) parameter.
c
c       Calling sequence substitutions:
c         aadhh for arr
c         adhh for prop
c
        call evdat2(aadhh,narxmx,narxt,ntpr,ntprmx,adhh,tempc)
c
        do ipc = 1,ipch
c
c         Compute the pressure derivatives of the Debye-Huckel A(H)
c         parameter.
c
c         Calling sequence substitutions:
c           adadhh for arr
c           ipc for k
c           ipchmx for nmax
c
          call evdat3(adadhh,ipc,ipchmx,narxmx,narxt,ntpr,ntprmx,
     $    prop,tempc)
          dadhh(ipc) = prop
        enddo
      endif
c
      if (ipcv .ge. 0) then
c
c       Compute the Debye-Huckel A(V) parameter.
c
c       Calling sequence substitutions:
c         aadhv for arr
c         adhv for prop
c
        call evdat2(aadhv,narxmx,narxt,ntpr,ntprmx,adhv,tempc)
c
        do ipc = 1,ipcv
c
c         Compute the pressure derivatives of the Debye-Huckel A(V)
c         parameter.
c
c         Calling sequence substitutions:
c           adadhv for arr
c           ipc for k
c           ipcvmx for nmax
c
          call evdat3(adadhv,ipc,ipcvmx,narxmx,narxt,ntpr,ntprmx,
     $    prop,tempc)
          dadhv(ipc) = prop
        enddo
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (iopg(1).eq.0 .or. iopg(1).eq.2) then
c
c       B-dot equation or HC + DH equations.
c
c       Compute the Debye-Huckel B(gamma) parameter.
c
c       Calling sequence substitutions:
c         abdh for arr
c         bdh for prop
c
        call evdat2(abdh,narxmx,narxt,ntpr,ntprmx,bdh,tempc)
c
        if (ipch .ge. 0) then
c
c         Compute the Debye-Huckel B(H) parameter.
c
c         Calling sequence substitutions:
c           abdhh for arr
c           bdhh for prop
c
          call evdat2(abdhh,narxmx,narxt,ntpr,ntprmx,bdhh,tempc)
c
          do ipc = 1,ipch
c
c           Compute the pressure derivatives of the Debye-Huckel B(H)
c           parameter.
c
c           Calling sequence substitutions:
c             adbdhh for arr
c             ipc for k
c             ipchmx for nmax
c
            call evdat3(adbdhh,ipc,ipchmx,narxmx,narxt,ntpr,ntprmx,
     $      prop,tempc)
            dbdhh(ipc) = prop
          enddo
        endif
c
        if (ipcv .ge. 0) then
c
c         Compute the Debye-Huckel B(V) parameter.
c
c         Calling sequence substitutions:
c           abdhv for arr
c           bdhv for prop
c
          call evdat2(abdhv,narxmx,narxt,ntpr,ntprmx,bdhv,tempc)
c
          do ipc = 1,ipcv
c
c           Compute the pressure derivatives of the Debye-Huckel B(V)
c           parameter.
c
c           Calling sequence substitutions:
c             adbdhv for arr
c             ipc for k
c             ipcvmx for nmax
c
            call evdat3(adbdhv,ipc,ipcvmx,narxmx,narxt,ntpr,ntprmx,
     $      prop,tempc)
            dbdhv(ipc) = prop
          enddo
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (iopg(1) .eq. 0) then
c
c       B-dot equation.
c
c       Compute the Helgeson (1969) B-dot parameter.
c
c       Calling sequence substitutions:
c         abdot for arr
c         bdot for prop
c
        call evdat2(abdot,narxmx,narxt,ntpr,ntprmx,bdot,tempc)
c
        if (ipch .ge. 0) then
c
c         Compute the Debye-Huckel B-dot(H) parameter.
c
c         Calling sequence substitutions:
c           abdoth for arr
c           bdoth for prop
c
          call evdat2(abdoth,narxmx,narxt,ntpr,ntprmx,bdoth,tempc)
c
          do ipc = 1,ipch
c
c           Compute the pressure derivatives of the Debye-Huckel
c           B-dot(H) parameter.
c
c           Calling sequence substitutions:
c             adbdth for arr
c             ipc for k
c             ipchmx for nmax
c
            call evdat3(adbdth,ipc,ipchmx,narxmx,narxt,ntpr,ntprmx,
     $      prop,tempc)
            dbdth(ipc) = prop
          enddo
        endif
c
        if (ipcv .ge. 0) then
c
c         Compute the Debye-Huckel B-dot(V) parameter.
c
c         Calling sequence substitutions:
c           abdotv for arr
c           bdotv for prop
c
          call evdat2(abdotv,narxmx,narxt,ntpr,ntprmx,bdotv,tempc)
c
          do ipc = 1,ipcv
c
c           Compute the pressure derivatives of the Debye-Huckel
c           B-dot(V) parameter.
c
c           Calling sequence substitutions:
c             adbdtv for arr
c             ipc for k
c             ipcvmx for nmax
c
            call evdat3(adbdtv,ipc,ipcvmx,narxmx,narxt,ntpr,ntprmx,
     $      prop,tempc)
            dbdtv(ipc) = prop
          enddo
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the log K for the 'Eh' reaction.
c
      if (axlke(1,ntpr) .lt. 9999999.) then
c
c       Calling sequence substitutions:
c         axlke for arr
c         xlke for prop
c
        call evdat2(axlke,narxmx,narxt,ntpr,ntprmx,xlke,tempc)
      else
        xlke = 9999999.
      endif
c
      if (ipch .ge. 0) then
c
c       Compute the enthalpy of reaction for the 'Eh' reaction.
c
        if (axhfe(1,ntpr) .lt. 9999999.) then
c
c         Calling sequence substitutions:
c           axhfe for arr
c           xhfe for prop
c
          call evdat2(axhfe,narxmx,narxt,ntpr,ntprmx,xhfe,tempc)
        else
          xhfe = 9999999.
        endif
c
        do ipc = 1,ipch
c
c         Compute the pressure derivatives of the enthalpy of
c         reaction for the 'Eh' reaction.
c
c         Calling sequence substitutions:
c           adhfe for arr
c           ipc for k
c           ipchmx for nmax
c
          call evdat3(adhfe,ipc,ipchmx,narxmx,narxt,ntpr,ntprmx,
     $    prop,tempc)
          dhfe(ipc) = prop
        enddo
      endif
c
      if (ipcv .ge. 0) then
c
c       Compute the volume of reaction for the 'Eh' reaction.
c
        if (axvfe(1,ntpr) .lt. 9999999.) then
c
c         Calling sequence substitutions:
c           axvfe for arr
c           xvfe for prop
c
          call evdat2(axvfe,narxmx,narxt,ntpr,ntprmx,xvfe,tempc)
        else
          xvfe = 9999999.
        endif
c
        do ipc = 1,ipcv
c
c         Compute the pressure derivatives of the volume of
c         reaction for the 'Eh' reaction.
c
c         Calling sequence substitutions:
c           advfe for arr
c           ipc for k
c           ipcvmx for nmax
c
          call evdat3(advfe,ipc,ipcvmx,narxmx,narxt,ntpr,ntprmx,
     $    prop,tempc)
          dvfe(ipc) = prop
        enddo
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the log K values for all reactions as they are
c     currently written.
c
      call evdatr(adhfs,advfs,axhfs,axlks,axvfs,dhfs,dvfs,
     $ ipch,ipchmx,ipcv,ipcvmx,narxmx,narxt,nst,nstmax,ntpr,ntprmx,
     $ tempc,xhfs,xlks,xvfs)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the log K values for all reactions as they were
c     written on the data file.
c
c     Calling sequence substitutions:
c       adhfsd for adhfs
c       advfsd for advfs
c       axhfsd for axhfs
c       axlksd for axlks
c       axvfsd for avhfs
c       dhfsd for dhfs
c       dvfsd for dvfs
c       xhfsd for xhfs
c       xlksd for xlks
c       xvfsd for xvfs
c
      call evdatr(adhfsd,advfsd,axhfsd,axlksd,axvfsd,dhfsd,dvfsd,
     $ ipch,ipchmx,ipcv,ipcvmx,narxmx,narxt,nst,nstmax,ntpr,ntprmx,
     $ tempc,xhfsd,xlksd,xvfsd)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute remaining temperature-dependent aqueous species activity
c     coefficient parameters.
c
      if (iopg(1) .eq. 1) then
c
c       Computer the S-lambda(n) and mu coefficients for Pitzer's
c       equations.
c
        call evptzc(amu,aslm,ipbtmx,jpfcmx,jptffl,nmut,nmutmx,
     $  noutpt,nttyo,nslt,nsltmx,pmu,pslamn,tempc)
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute temperature dependent solid solution activity
c     coefficient parameters.
c
      if (iopt(4) .ge. 1) then
        call wterm(apx,iapxmx,iktmax,ixrn1,ixrn2,jsol,ncmpr,
     $  noutpt,nptmax,nstmax,nttyo,nxt,nxtmax,press,tempk,uphase,
     $  uspec,wfac)
      endif
c
      end


module parcel_netcdf
    use constants, only : one
    use netcdf_utils
    use netcdf_writer
    use netcdf_reader
    use parcel_container, only : parcels, n_parcels
    use parameters, only : nx, ny, nz, extent, lower, max_num_parcels
    use config, only : package_version, cf_version
    use timer, only : start_timer, stop_timer
    use iomanip, only : zfill
    use options, only : write_netcdf_options
    use physics, only : write_physical_quantities
    implicit none

    integer :: parcel_io_timer

    integer :: n_writes = 1
    character(len=512) :: ncbasename

    character(len=512) :: ncfname
    integer            :: ncid
    integer            :: npar_dim_id, vol_id, buo_id,  &
                          x_pos_id, y_pos_id, z_pos_id, &
                          x_vor_id, y_vor_id, z_vor_id, &
                          b11_id, b12_id, b13_id,       &
                          b22_id, b23_id,               &
                          t_axis_id, t_dim_id
    double precision   :: restart_time

#ifndef ENABLE_DRY_MODE
    integer :: hum_id
#endif

    private :: ncid, ncfname, n_writes, npar_dim_id,    &
               x_pos_id, y_pos_id, z_pos_id,            &
               x_vor_id, y_vor_id, z_vor_id,            &
               b11_id, b12_id, b13_id, b22_id, b23_id,  &
               vol_id, buo_id, t_dim_id, t_axis_id,     &
               restart_time

#ifndef ENABLE_DRY_MODE
    private :: hum_id
#endif

    private :: ncbasename

    contains

        ! Create the parcel file.
        ! @param[in] basename of the file
        ! @param[in] overwrite the file
        subroutine create_netcdf_parcel_file(basename, overwrite, l_restart)
            character(*), intent(in)  :: basename
            logical,      intent(in)  :: overwrite
            logical,      intent(in)  :: l_restart
            logical                   :: l_exist
            integer                   :: dimids(2)

            ncfname =  basename // '_' // zfill(n_writes) // '_parcels.nc'

            ncbasename = basename

            restart_time = -one

            if (l_restart) then
                ! find the last parcel file in order to set "n_writes" properly
                call exist_netcdf_file(ncfname, l_exist)
                do while (l_exist)
                    n_writes = n_writes + 1
                    ncfname =  basename // '_' // zfill(n_writes) // '_parcels.nc'
                    call exist_netcdf_file(ncfname, l_exist)
                    if (l_exist) then
                        call open_netcdf_file(ncfname, NF90_NOWRITE, ncid)
                        call get_time(ncid, restart_time)
                        call close_netcdf_file(ncid)
                    endif
                enddo
                return
            endif

            call create_netcdf_file(ncfname, overwrite, ncid)

            ! define global attributes
            call write_netcdf_info(ncid=ncid,                    &
                                   epic_version=package_version, &
                                   file_type='parcels',          &
                                   cf_version=cf_version)

            call write_netcdf_box(ncid, lower, extent, (/nx, ny, nz/))

            call write_physical_quantities(ncid)

            call write_netcdf_options(ncid)

            ! define dimensions
            call define_netcdf_dimension(ncid=ncid,                         &
                                         name='n_parcels',                  &
                                         dimsize=n_parcels,                 &
                                         dimid=npar_dim_id)

            call define_netcdf_temporal_dimension(ncid, t_dim_id, t_axis_id)

            dimids = (/npar_dim_id, t_dim_id/)

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='x_position',                   &
                                       long_name='x position component',    &
                                       std_name='',                         &
                                       unit='m',                            &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=x_pos_id)

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='y_position',                   &
                                       long_name='y position component',    &
                                       std_name='',                         &
                                       unit='m',                            &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=y_pos_id)

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='z_position',                   &
                                       long_name='z position component',    &
                                       std_name='',                         &
                                       unit='m',                            &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=z_pos_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='B11',                              &
                                       long_name='B11 element of shape matrix', &
                                       std_name='',                             &
                                       unit='m^2',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=b11_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='B12',                              &
                                       long_name='B12 element of shape matrix', &
                                       std_name='',                             &
                                       unit='m^2',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=b12_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='B13',                              &
                                       long_name='B13 element of shape matrix', &
                                       std_name='',                             &
                                       unit='m^2',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=b13_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='B22',                              &
                                       long_name='B22 element of shape matrix', &
                                       std_name='',                             &
                                       unit='m^2',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=b22_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='B23',                              &
                                       long_name='B23 element of shape matrix', &
                                       std_name='',                             &
                                       unit='m^2',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=b23_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='volume',                           &
                                       long_name='parcel volume',               &
                                       std_name='',                             &
                                       unit='m^3',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=vol_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='x_vorticity',                      &
                                       long_name='x vorticity component',       &
                                       std_name='',                             &
                                       unit='1/s',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=x_vor_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='y_vorticity',                      &
                                       long_name='y vorticity component',       &
                                       std_name='',                             &
                                       unit='1/s',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=y_vor_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='z_vorticity',                      &
                                       long_name='z vorticity component',       &
                                       std_name='',                             &
                                       unit='1/s',                              &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=z_vor_id)

            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='buoyancy',                         &
                                       long_name='parcel buoyancy',             &
                                       std_name='',                             &
                                       unit='m/s^2',                            &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=buo_id)

#ifndef ENABLE_DRY_MODE
            call define_netcdf_dataset(ncid=ncid,                               &
                                       name='humidity',                         &
                                       long_name='parcel humidity',             &
                                       std_name='',                             &
                                       unit='1',                                &
                                       dtype=NF90_DOUBLE,                       &
                                       dimids=dimids,                           &
                                       varid=hum_id)
#endif

            call close_definition(ncid)

        end subroutine create_netcdf_parcel_file

        ! Write parcels of the current time step into the parcel file.
        ! @param[in] t is the time
        subroutine write_netcdf_parcels(t)
            double precision, intent(in) :: t
            integer                      :: cnt(2), start(2)

            call start_timer(parcel_io_timer)

            if (t <= restart_time) then
                call stop_timer(parcel_io_timer)
                return
            endif

            call create_netcdf_parcel_file(trim(ncbasename), .true., .false.)

            call open_netcdf_file(ncfname, NF90_WRITE, ncid)

            ! write time
            call write_netcdf_scalar(ncid, t_axis_id, t, 1)

            ! time step to write [step(2) is the time]
            cnt   = (/ n_parcels, 1 /)
            start = (/ 1,         1 /)

            call write_netcdf_dataset(ncid, x_pos_id, parcels%position(1, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, y_pos_id, parcels%position(2, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, z_pos_id, parcels%position(3, 1:n_parcels), start, cnt)

            call write_netcdf_dataset(ncid, b11_id, parcels%B(1, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, b12_id, parcels%B(2, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, b13_id, parcels%B(3, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, b22_id, parcels%B(4, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, b23_id, parcels%B(5, 1:n_parcels), start, cnt)

            call write_netcdf_dataset(ncid, vol_id, parcels%volume(1:n_parcels), start, cnt)

            call write_netcdf_dataset(ncid, x_vor_id, parcels%vorticity(1, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, y_vor_id, parcels%vorticity(2, 1:n_parcels), start, cnt)
            call write_netcdf_dataset(ncid, z_vor_id, parcels%vorticity(3, 1:n_parcels), start, cnt)

            call write_netcdf_dataset(ncid, buo_id, parcels%buoyancy(1:n_parcels), start, cnt)

#ifndef ENABLE_DRY_MODE
            call write_netcdf_dataset(ncid, hum_id, parcels%humidity(1:n_parcels), start, cnt)
#endif
            ! increment counter
            n_writes = n_writes + 1

            call close_netcdf_file(ncid)

            call stop_timer(parcel_io_timer)

        end subroutine write_netcdf_parcels

        subroutine read_netcdf_parcels(fname)
            character(*),     intent(in) :: fname
            logical                      :: l_valid = .false.
            integer                      :: cnt(2), start(2)

            call start_timer(parcel_io_timer)

            call open_netcdf_file(fname, NF90_NOWRITE, ncid)

            call get_num_parcels(ncid, n_parcels)

            if (n_parcels > max_num_parcels) then
                print *, "Number of parcels exceeds limit of", &
                          max_num_parcels, ". Exiting."
                stop
            endif

            ! time step to read [step(2) is the time]
            cnt   = (/ n_parcels, 1 /)
            start = (/ 1,         1 /)

            ! Be aware that the starting index of buffer_1d and buffer_2d
            ! is 0; hence, the range is 0:n_parcels-1 in contrast to the
            ! parcel container where it is 1:n_parcels.

            if (has_dataset(ncid, 'B11')) then
                call read_netcdf_dataset(ncid, 'B11', parcels%B(1, 1:n_parcels), start, cnt)
            else
                print *, "The parcel shape component B11 must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'B12')) then
                call read_netcdf_dataset(ncid, 'B12', parcels%B(2, 1:n_parcels), start, cnt)
            else
                print *, "The parcel shape component B12 must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'B13')) then
                call read_netcdf_dataset(ncid, 'B13', parcels%B(3, 1:n_parcels), start, cnt)
            else
                print *, "The parcel shape component B13 must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'B22')) then
                call read_netcdf_dataset(ncid, 'B22', parcels%B(4, 1:n_parcels), start, cnt)
            else
                print *, "The parcel shape component B22 must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'B23')) then
                call read_netcdf_dataset(ncid, 'B23', parcels%B(5, 1:n_parcels), start, cnt)
            else
                print *, "The parcel shape component B23 must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'x_position')) then
                call read_netcdf_dataset(ncid, 'x_position', &
                                         parcels%position(1, 1:n_parcels), start, cnt)
            else
                print *, "The parcel x position must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'y_position')) then
                call read_netcdf_dataset(ncid, 'y_position', &
                                         parcels%position(2, 1:n_parcels), start, cnt)
            else
                print *, "The parcel y position must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'z_position')) then
                call read_netcdf_dataset(ncid, 'z_position', &
                                         parcels%position(3, 1:n_parcels), start, cnt)
            else
                print *, "The parcel z position must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'volume')) then
                call read_netcdf_dataset(ncid, 'volume', &
                                         parcels%volume(1:n_parcels), start, cnt)
            else
                print *, "The parcel volume must be present! Exiting."
                stop
            endif

            if (has_dataset(ncid, 'x_vorticity')) then
                l_valid = .true.
                call read_netcdf_dataset(ncid, 'x_vorticity', &
                                         parcels%vorticity(1, 1:n_parcels), start, cnt)
            endif

            if (has_dataset(ncid, 'y_vorticity')) then
                call read_netcdf_dataset(ncid, 'y_vorticity', &
                                         parcels%vorticity(2, 1:n_parcels), start, cnt)
            endif

            if (has_dataset(ncid, 'z_vorticity')) then
                l_valid = .true.
                call read_netcdf_dataset(ncid, 'z_vorticity', &
                                         parcels%vorticity(3, 1:n_parcels), start, cnt)
            endif

            if (has_dataset(ncid, 'buoyancy')) then
                l_valid = .true.
                call read_netcdf_dataset(ncid, 'buoyancy', &
                                         parcels%buoyancy(1:n_parcels), start, cnt)
            endif

#ifndef ENABLE_DRY_MODE
            if (has_dataset(ncid, 'humidity')) then
                l_valid = .true.
                call read_netcdf_dataset(ncid, 'humidity', &
                                         parcels%humidity(1:n_parcels), start, cnt)
            endif
#endif

            if (.not. l_valid) then
                print *, "Either the parcel buoyancy or vorticity must be present! Exiting."
                stop
            endif

            call close_netcdf_file(ncid)

            call stop_timer(parcel_io_timer)

        end subroutine read_netcdf_parcels

end module parcel_netcdf


      SUBROUTINE GPRINT
C
C    *****************************************************************
C     SUBROUTINE GPRINT(WITH ENTRY POINT SPRINT) IS THE EXECUTIVE
C     ROUTINE TO CONTROL THE NORMAL PRINT OUTPUT, IT CALLS SUBROUTINE
C     SET TO PERFORM THE PRINTED FSD PROGRAM OUTPUT.
C    *****************************************************************
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      INTEGER*4 ACNTRL
      REAL*8 MSUBM
C
C
      COMMON/CANTNA/ A(10,3),ADOT(10,3),B(10,3),BDOT(10,3),DIN(10,3),
     .               DINDOT(10,3),DOUT(10,3),DOUTDT(10,3)
C
      COMMON/CONSTS/ PI,TWOPI,RADIAN
C
      COMMON/CWHEEL/ VWH(3),VDUMY(6)
C
      COMMON/DEBUG1/ IAFM(5)
C
      COMMON/DMMNT1/ ZKBM(6),FMAK(10),FMBK(10),ARTETA(3),CMTORK(3),
     .               ITORK,IBENDM,ITENSE,ITNS1
C
      COMMON/DRPROT/ STAGP
C
      COMMON/ECNSTS/ THETA1,THETGO(12)
C
      COMMON/ELMNTS/ NELMTS,NDAMPR
C
      COMMON/HAMOUT/ HAMILT,IHAMLT
C
      COMMON/ICNTRL/ KNTRL(10)
C
      COMMON/IPOOL1/ IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10),
     .               LK(10),LLK(10)
C
      COMMON/ISHADE/ IPLANS,ISATSH,IWRTTF
C
      COMMON/MOMENT/ ACNTRL,IVISCS,IATTDE,IMGMTS,IWHEEL,NPULSE
C
      COMMON/NODER / NDER,NOPT
C
      COMMON/NUTANG/ ANGNUT
C
      COMMON/OUTONE/ OMEGL,VSUBL,MSUBM(3),CMX,SIMPX,SB(3)
C
      COMMON/OUTTWO/ SOLILL,EPSERR
C
      COMMON/OUTTHR/ SMAGB(3),XMB(3),RWHEEL(3)
C
      COMMON/OUTFOR/ OMEGDT(3)
C
      COMMON/PRCOM / STORE(10,30),ILINE,ICOL,ICNT,IHD
C
      COMMON/RMAIN1/ DELTAT,FACTOR,FREQ,TSTOP,DELMIT,
     .               UPBND(150),DNBND(150)
C
      COMMON/RMGNTC/ SMAGI(3),DPMAG(3),SFMAG,MAGFLD
C
      COMMON/RPOOL1/ RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/RPOOL3/ZMS,DUMMM(6)
C
      COMMON/RPOOL9/ RT1(7),RT2(10,9),ALP(7,7),GAM(10,9,7),DEL(10,9,9)
C
      COMMON/SOLOUT/ FTAKIN(10,3),FTAKOT(10,3),FTBKIN(10,3),FTBKOT(10,3)
C
      COMMON/SUBPOS/ ALAT,ALONG,HGT
C
      COMMON/SUNANG/ DSL2
C
      COMMON/SUNVTR/ SSSLLL(3)
C
      COMMON/TENSON/ TSSO(10)
C
      COMMON/VARBLS/ DEPEND(150),DERIV(150)
C
      COMMON/VECTRS/ XSAT(3),XSATDT(3),AD(3)
C
      COMMON/XIN1  / PSI1,THET1,PHI1,ETTA,ZETTA,ITEST1
C
      COMMON/XIN2  / ALFAE,BETAE,GAMAE,OMBC(3),ITEST2
C
C     MODIFICATION FOR GPRINT
C     ADD NEW COMMONS
C
      COMMON/HOUTPT/ IHCALC,IHREF,IHFLAG
C
      COMMON/HVCOUT/ HBODY(3),HINERT(3),HMAG
C
C
C   MOD OF ACCELERATION COMPUTATION IN GPRINT
C
C   ADD COMMON FOR ACCELERATION COMPUTATION
C
      COMMON/IACC  / IACOMP,IHUBAC,ITIPAC
C
      COMMON/ACCHUB/ YHUB(3,6),HUBACC(3,6),ACCRED(6),ALFAEA(6),
     .               BETAEA(6),GAMAEA(6),DKAT(3,3,6)
C
      COMMON/ACCORB/ ACCOB(3),TRTACC(3)
C
      COMMON/SEPACC/ CENACC(3,10),CORACC(3,10),DLIACC(3,10),TIPACC(3,10)
C
      COMMON/NUMACC/ NUMHUB
C
      COMMON/GRNTST/ ALFAEG,DELTAG,PHASEG,ALTUDE,OMGY(3),
     *               GACC(3),GLOCAT(3),IGRUND,IALTUD
C
      COMMON/GRNOUT/ ALFAG,DELTG,PHASG,OMGN(3)
C
      COMMON/ITW   / ITWIST,ITWST1
C
      COMMON/INEWR / NKT(10),IABCDE(2)
C
      COMMON/TWIOUT/ CW(10,3),CWD(10,3)
C
C
      DIMENSION SUMD(10),SUMDT(10),SUMDIN(10),SUMDNT(10),SUMA(10),
     .          SUMB(10),SUMAD(10),SUMBD(10)
C
      DIMENSION YCEMS(3)
      DIMENSION FMT(25)
      DIMENSION GAMES(4,2,2),INAM(4,2,2)
C
      DATA ISIZE /0/
      DATA FMD/'F12.0   '/,FMD1/'F12.3   '/
      DATA I2/',A2,'/
      DATA I3 /',A3,'/
      DATA I4 /',A4,'/
      DATA I5 /',A5,'/
      DATA I6 /',A6,'/
      DATA I8/',A8,'/
      DATA PAR1 /'(       '/, PAR2/')       '/
      DATA SKIP /' 1H0,   '/, CC /'1H ,    '/
      DATA FM3/'D12.5   '/,FM5/',1X,    '/,FM2/'2X,A8,2X'/
      DATA STARS /'********'/
      DATA GAMES /'DOUT    ','DOUTDT  ','DIN     ','DINDOT  ',
     .            'A       ','ADOT    ','B       ','BDOT    ',
     .            'UD3     ','UD3DT   ','UD2     ','UD2DT   ',
     .            'U3      ','U3DOT   ','U2      ','U2DOT   '/
      DATA INAM  /',A4,',',A6,',',A3,',',A6,',
     .            ',A1,',',A4,',',A1,',',A4,',
     .            ',A3,',',A5,',',A3,',',A5,',
     .            ',A2,',',A5,',',A2,',',A5,'/
C
      ISP=0
      GO TO 500
      ENTRY SPRINT
      ISP=1
  500 FMT(1)=PAR1
      BLANK=10D-38
      ILINE=1
      ICOL=0
C
C        TEST FOR HEADING,NO HEADING CONDITIONS
C
      IF(ICNT.GT.60) GO TO 650
      IF(ISIZE.GT.(60-ICNT)) GO TO 650
C
C        IHD = 1 MEANS HEADING
C        IHD = 0 MEANS NO HEADING
      IHD=0
      GO TO 690
  650 IHD=1
      ICNT=0
C
C        OUTPUT DATA VIA SUBROUTINE SET
  690 CALL TCNVRT (YMD,TEMP,SEC,TLAST,TIME,2)
      CALL SET ('DATE    ',0,0,YMD,I4)
      HMS=HMSOUT(DMOD(SEC,86400.D0))
      CALL SET ('TIME    ',0,0,HMS,I4)
      IF(IGRUND.EQ.1)  GO TO 400
      DO 720 I=1,3
  720 CALL SET ('XSAT    ',I,0,XSAT(I),I4)
      DO 750 I=1,3
  750 CALL SET ('XSATDT  ',I,0,XSATDT(I),I6)
      RMAG=DSQRT(XSAT(1)**2+XSAT(2)**2+XSAT(3)**2)
      CALL SET ('RMAG    ',0,0,RMAG,I4)
      CALL SET('STAG PR ',0,0,STAGP,I8)
C
      CALL XYZPLH(XSAT)
      ALAT=ALAT/RADIAN
      ALONG=ALONG/RADIAN
      CALL SET ('LAT     ',0,0,ALAT,I3)
      CALL SET ('LONG    ',0,0,ALONG,I4)
      CALL SET ('ALT     ',0,0,HGT,I4)
 400  CONTINUE
      CALL SET ('DELTAT  ',0,0,DELTAT,I6)
      IF(IGRUND.EQ.1.AND.IGASBR.EQ.0)  GO TO 798
      DO 823 I=1,3
      DO 823 J=1,3
  823 CALL SET('SA      ',I,J,SA(I,J),I2)
 798  CONTINUE
      IF(IGRUND.EQ.1)  GO TO 410
      IF(ISP.EQ.1) GO TO 920
      CALL SET ('ALFAE   ',0,0,ALFAE,I5)
      IF(ITEST2.EQ.0) GO TO 890
      CALL SET ('BETAE   ',0,0,BETAE,I5)
      CALL SET ('GAMAE   ',0,0,GAMAE,I5)
      GO TO 990
  890 CALL SET ('BETAE   ',0,0,BLANK,I5)
      CALL SET ('GAMAE   ',0,0,BLANK,I5)
      GO TO 990
  920 CALL SET ('THET1   ',0,0,THET1,I5)
      IF(ITEST1.EQ.0) GO TO 970
      CALL SET ('PSI1    ',0,0,PSI1,I4)
      CALL SET ('PHI1    ',0,0,PHI1,I4)
      GO TO 1020
  970 CALL SET ('PSI1    ',0,0,BLANK,I4)
      CALL SET ('PHI1    ',0,0,BLANK,I4)
      GO TO 1020
  990 CALL SET ('W1BC    ',0,0,OMBC(1),I4)
      CALL SET ('W2BC    ',0,0,OMBC(2),I4)
      CALL SET ('W3BC    ',0,0,OMBC(3),I4)
      AL=ALFAE*RADIAN
      BE=BETAE*RADIAN
      GA=GAMAE*RADIAN
      RRAT=OMBC(1)*DCOS(GA)-OMBC(2)*DSIN(GA)
      PRAT=(OMBC(1)*DSIN(GA)+OMBC(2)*DCOS(GA))/DCOS(AL)
      YRAT=OMBC(3)+DTAN(AL)*(OMBC(1)*DSIN(GA)+OMBC(2)*DCOS(GA))
      CALL SET('RRAT    ',0,0,RRAT,I4)
      CALL SET('PRAT    ',0,0,PRAT,I4)
      CALL SET('YRAT    ',0,0,YRAT,I4)
 1020 DEGREE=180/PI
      W1B=DEPEND(7)*DEGREE
      W2B=DEPEND(8)*DEGREE
      W3B=DEPEND(9)*DEGREE
      CALL SET ('W1B     ',0,0,W1B,I3)
      CALL SET ('W2B     ',0,0,W2B,I3)
      CALL SET ('W3B     ',0,0,W3B,I3)
      GO TO 430
 410  CONTINUE
      CALL SET('ALFAG   ',0,0,ALFAG,I5)
      CALL SET('DELTG   ',0,0,DELTG,I5)
      CALL SET('W1GY    ',0,0,OMGN(1),I4)
      CALL SET('W2GY    ',0,0,OMGN(2),I4)
      CALL SET('W3GY    ',0,0,OMGN(3),I4)
 430  CONTINUE
      DO 1085 I=1,3
 1085 CALL SET('MOMENT  ',I,0,OMEGDT(I),I6)
      JELMNT=0
      JDAMPR=0
C
      DO 4510 K=1,IK
      IY=K-K1
      JWZ=IY
      IF (IY.LE.0) JWZ=K
      IF (IBENDM.EQ.0) GO TO 700
      CALL SET('BNMTA   ',JWZ,0, FMAK(K), I5)
      CALL SET('BNMTB   ',JWZ,0, FMBK(K), I5)
  700 IF (ITENSE.EQ.0) GO TO 4510
      CALL SET('TENSN   ',JWZ,0, TSSO(K),I5)
 4510 CONTINUE
      DO 1170 K=1,IK
      M=NK(K)
      IF(M.EQ.0) GO TO 1170
      IF((K-K1).GT.0) GO TO 1140
      IF(JDAMPR.EQ.1) GO TO 1140
C
      DO 1130 I=1,NDAMPR
C
      SUMD(I)=0.D0
      SUMDT(I)=0.D0
      SUMDIN(I)=0.D0
      SUMDNT(I)=0.D0
      IF(NK(I).EQ.0) GO TO 1130
C
      DO 1120 J=1,M
C
      SUMD(I)=SUMD(I) + DOUT(I,J)
      SUMDT(I)=SUMDT(I) + DOUTDT(I,J)
      SUMDIN(I)=SUMDIN(I) + DIN(I,J)
      SUMDNT(I)=SUMDNT(I) + DINDOT(I,J)
C
      CALL SET(GAMES(1,1,1),I,J,DOUT(I,J),INAM(1,1,1))
      CALL SET(GAMES(2,1,1),I,J,DOUTDT(I,J),INAM(2,1,1))
      CALL SET(GAMES(3,1,1),I,J,DIN(I,J),INAM(3,1,1))
      CALL SET(GAMES(4,1,1),I,J,DINDOT(I,J),INAM(4,1,1))
C
      IF (IWRTTF.EQ.0) GO TO 1120
      CALL SET('FTAKIN  ',I,J,FTAKIN(I,J), I6)
      CALL SET('FTAKOT  ',I,J,FTAKOT(I,J), I6)
      CALL SET('FTBKIN  ',I,J,FTBKIN(I,J), I6)
      CALL SET('FTBKOT  ',I,J,FTBKOT(I,J), I6)
 1120 CONTINUE
C
 1130 CONTINUE
      JDAMPR=1
      GO TO 1170
 1140 IF(JELMNT.EQ.1) GO TO 1170
      DO 1160 I=1,NELMTS
      SUMA(I)=0.D0
      SUMB(I)=0.D0
      SUMAD(I)=0.D0
      SUMBD(I)=0.D0
      KK=I+K1
      IF(NK(KK).EQ.0) GO TO 1160
      M=NK(KK)
C
      DO 1150 J=1,M
C
      SUMA(I)=SUMA(I) + B(I,J)
      SUMB(I)=SUMB(I) + A(I,J)
      SUMAD(I)=SUMAD(I) + BDOT(I,J)
      SUMBD(I)=SUMBD(I) + ADOT(I,J)
C
      CALL SET(GAMES(1,2,1),I,J,A(I,J),INAM(1,2,1))
      CALL SET(GAMES(2,2,1),I,J,ADOT(I,J),INAM(2,2,1))
      CALL SET(GAMES(3,2,1),I,J,B(I,J),INAM(3,2,1))
      CALL SET(GAMES(4,2,1),I,J,BDOT(I,J),INAM(4,2,1))
C
      IF (IWRTTF.EQ.0) GO TO 1150
      CALL SET('FTAKIN  ',I,J,FTAKIN(I,J), I6)
      CALL SET('FTAKOT  ',I,J,FTAKOT(I,J), I6)
      CALL SET('FTBKIN  ',I,J,FTBKIN(I,J), I6)
      CALL SET('FTBKOT  ',I,J,FTBKOT(I,J), I6)
 1150 CONTINUE
 1160 CONTINUE
      JELMNT=1
 1170 CONTINUE
C
      DO 1210 K=1,IK
      IF(NK(K).EQ.0) GO TO 1210
      IF((K-K1).GT.0) GO TO 1190
      IF(JDAMPR.EQ.2) GO TO 1190
C
      DO 1180 I=1,NDAMPR
      IF(NK(I).EQ.0) GO TO 1180
      CALL SET(GAMES(1,1,2),I,0,SUMD(I),INAM(1,1,2))
      CALL SET(GAMES(2,1,2),I,0,SUMDT(I),INAM(2,1,2))
      CALL SET(GAMES(3,1,2),I,0,SUMDIN(I),INAM(3,1,2))
      CALL SET(GAMES(4,1,2),I,0,SUMDNT(I),INAM(4,1,2))
 1180 CONTINUE
      JDAMPR=2
C
      GO TO 1210
 1190 IF(JELMNT.EQ.2) GO TO 1210
      DO 1200 I=1,NELMTS
      II=I+K1
      IF(NK(II).EQ.0) GO TO 1200
      CALL SET(GAMES(1,2,2),I,0,SUMA(I),INAM(1,2,2))
      CALL SET(GAMES(2,2,2),I,0,SUMAD(I),INAM(2,2,2))
      CALL SET(GAMES(3,2,2),I,0,SUMB(I),INAM(3,2,2))
      CALL SET(GAMES(4,2,2),I,0,SUMBD(I),INAM(4,2,2))
 1200 CONTINUE
      JELMNT=2
 1210 CONTINUE
C
C
      IF(ITWIST.EQ.0) GO TO 1212
      DO 1211 I=1,IK
      NTW=NKT(I)
      IF(NTW.EQ.0) GO TO 1211
      DO 1213 J=1,NTW
      CALL SET('CW      ',I,J,CW(I,J),I2)
      CALL SET('CWD     ',I,J,CWD(I,J),I3)
 1213 CONTINUE
 1211 CONTINUE
 1212 CONTINUE
C
C
      DO 1580 I=1,IK
      IF(ZLK(I).EQ.0) GO TO 1580
      IF(I.GT.K1) GO TO 1570
      CALL SET ('ZLD     ',I,0,ZLK(I),I3)
      GO TO 1580
 1570 CALL SET ('ZLK     ',I-K1,0,ZLK(I),I3)
 1580 CONTINUE
C
      CALL GPSOUT
C
      CALL SECOUT
C
      IF(IDAMP.EQ.0) GO TO 1620
      PHILD=DEPEND(10)/RADIAN
      DPHILD=DEPEND(11)/RADIAN
      CALL SET ('PHILD   ',0,0,PHILD,I5)
      CALL SET ('DPHILD  ',0,0,DPHILD,I6)
 1620 IF(ISP.EQ.0) GO TO 1710
      IF(IVISCS.EQ.0) GO TO 1680
      CALL SET ('OMEGL   ',0,0,OMEGL,I5)
      CALL SET ('VSUBL   ',0,0,VSUBL,I5)
      DO 1670 I=1,3
 1670 CALL SET ('MSUBM   ',I,0,MSUBM(I),I5)
 1680 IF(IATTDE.EQ.0) GO TO 1710
      CALL SET ('CMX     ',0,0,CMX,I3)
      CALL SET ('SIMPX   ',0,0,SIMPX,I5)
 1710 IF(IMGMTS.EQ.0) GO TO 1780
      DO 1730 I=1,3
 1730 CALL SET ('XMB     ',I,0,XMB(I),I3)
      DO 1750 I=1,3
 1750 CALL SET ('SMAGI   ',I,0,SMAGI(I),I5)
      DO 1770 I=1,3
 1770 CALL SET ('SMAGB   ',I,0,SMAGB(I),I5)
 1780 CONTINUE
      IF(IGRUND.EQ.1)  GO TO 420
      CALL SET ('SOLILL  ',0,0,SOLILL,I6)
      CALL SET ('SUNANG  ',0,0,DSL2,I6)
      IF(IAFM(1).EQ.0) GO TO 420
      DO 3000 I=1,3
      CALL SET('SUNVEC  ',I,0,SSSLLL(I),I6)
 3000 CONTINUE
 420  CONTINUE
      IF(IWHEEL.EQ.0) GO TO 1815
      DO 1810 I=1,3
      CALL SET('WHL SPD ',I,0,VWH(I),I8)
 1810 CALL SET ('RWHEEL  ',I,0,RWHEEL(I),I6)
C
      IF(KNTRL(1).NE.0) CALL DEBOUT
C
 1815 IF(ISP.EQ.0.AND.IGRUND.EQ.0) GO TO 1820
      IF(IHREF.EQ.1) GO TO 1818
      CALL SET('EPSERR  ',0,0,EPSERR,I6)
      GO TO 1819
 1818 CONTINUE
      EPSERH=EPSERR
      CALL SET('EPSERH  ',0,0,EPSERH,I6)
 1819 CONTINUE
 1820 IF (NOPT.EQ.0) GO TO 1821
      ANDER=NDER
      CALL SET ('NO DEREQ',0,0,ANDER,I8)
      NDER=0
 1821 IF(IHAMLT.NE.0) CALL SET('HAMILTON',0,0,HAMILT,I8)
      IF(IACOMP.EQ.0) GO TO 2000
      DO 2100 I=1,3
      CALL SET('ACCOB   ',I,0,ACCOB(I),I5)
 2100 CONTINUE
      IF(IHUBAC.EQ.0) GO TO 2200
      DO 2300 I=1,NUMHUB
      CALL SET('ACCRED  ',I,0,ACCRED(I),I6)
      DO 2300 J=1,3
      CALL SET('HUBACC  ',J,I,HUBACC(J,I),I6)
 2300 CONTINUE
 2200 CONTINUE
      IF(ITIPAC.EQ.0) GO TO 2000
      DO 2400 I=1,NELMTS
      DO 2400 J=1,3
      CALL SET('TIPACC  ',J,I,TIPACC(J,I),I6)
 2400 CONTINUE
 2000 CONTINUE
      IF(IHCALC.EQ.0) GO TO 1685
      DO 1692 I=1,3
      CALL SET('HBODY   ',I,0,HBODY(I),I5)
 1692 CONTINUE
      CALL SET('NUT ANG ',0,0,ANGNUT,I8)
      DO 1693 I=1,3
      CALL SET('HVECTR  ',I,0,HINERT(I),I6)
 1693 CONTINUE
      CALL SET('HMAG    ',0,0,HMAG,I5)
 1685 CONTINUE
      CALL SET('ZMS     ',0,0,ZMS,I4)
      DO 1694 I=1,3
      YCEMS(I)=YBCM(I)/ZMS
      CALL SET('YCEMS   ',I,0,YCEMS(I),I5)
 1694 CONTINUE
      BIXX=ALP(4,4)
      BIYY=ALP(5,5)
      BIZZ=ALP(6,6)
      BIXY=-ALP(4,5)
      BIXZ=-ALP(4,6)
      BIYZ=-ALP(5,6)
      CALL SET('BIXX    ',0,0,BIXX,I4)
      CALL SET('BIYY    ',0,0,BIYY,I4)
      CALL SET('BIZZ    ',0,0,BIZZ,I4)
      CALL SET('BIXY    ',0,0,BIXY,I4)
      CALL SET('BIXZ    ',0,0,BIXZ,I4)
      CALL SET('BIYZ    ',0,0,BIYZ,I4)
 1686 IF((IHD.EQ.1).AND.(ICOL.LT.10)) CALL SETEND
C
      ISIZE=ILINE+1
      ICNT=ICNT+ISIZE
      DO 1910 J=1,ILINE
      FMT(2) = CC
      IF(J.EQ.1) FMT(2)=SKIP
      L=10
      IF(ILINE.EQ.J) L=ICOL
      DO 1900 I=1,L
      K=(I-1)*2+3
      IF(STORE(I,J).EQ.BLANK ) GO TO 1930
      FMT(K)=FM3
      IF(J.EQ.1.AND.I.EQ.1) FMT(K)=FMD
      IF (J.EQ.1.AND.I.EQ.2) FMT(K)=FMD1
      IF (J.EQ.ILINE.AND.I.EQ.L.AND.NOPT.NE.0) FMT(K)=FMD1
 1890 FMT(K+1)=FM5
      N=K
      GO TO 1900
 1930 STORE(I,J)=STARS
      FMT(K)=FM2
      GO TO 1890
 1900 CONTINUE
      FMT(N+1)=PAR2
      WRITE(6,FMT)(STORE(II,J),II=1,L)
 1910   CONTINUE
      RETURN
      END


      DOUBLE PRECISION FUNCTION PHO_PMASS(Id,Mode)
C***********************************************************************
C
C     particle mass
C
C     input:  mode  -1   initialization
C                    0   ID gives CPC particle number
C                    1   ID gives PDG particle number,
C                        (for quarks current masses are returned)
C                    2   ID gives position of particle in /POEVT1/
C                    3   ID gives PDG parton number,
C                        (for quarks constituent masses are returned)
C
C     output: average particle mass (in GeV)
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER Id , Mode , mstj24

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'

C  standard particle data interface

      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

C  particle ID translation table
      INCLUDE 'inc/popar1'
C  general particle data
      INCLUDE 'inc/popar2'

      INCLUDE 'inc/pydat1'

C  external functions
      INTEGER IPHO_PDG2ID , IPHO_ID2PDG

      DOUBLE PRECISION PYMASS

C  local variables
      INTEGER i , idpdg

      PHO_PMASS = 0.D0

      IF ( Mode.EQ.0 ) THEN
         i = Id
      ELSE IF ( Mode.EQ.1 ) THEN
         i = IPHO_PDG2ID(Id)
         IF ( i.EQ.0 ) RETURN
      ELSE IF ( Mode.EQ.2 ) THEN
         IF ( ISThep(Id).GT.11 ) RETURN
         i = IMPart(Id)
         idpdg = IDHep(Id)
         IF ( (idpdg.EQ.90) .OR. (idpdg.EQ.91) .OR. (idpdg.EQ.92) ) THEN
            PHO_PMASS = PHEp(5,Id)
            RETURN
         END IF
      ELSE IF ( Mode.EQ.3 ) THEN
         i = ABS(Id)
         IF ( (i.GT.0) .AND. (i.LE.6) ) THEN
            PHO_PMASS = PARmdl(150+i)
            RETURN
         ELSE
            i = IPHO_PDG2ID(Id)
            IF ( i.EQ.0 ) RETURN
         END IF
      ELSE IF ( Mode.EQ.-1 ) THEN
C  initialization: take masses for quarks and di-quarks from JETSET
         mstj24 = MSTj(24)
         MSTj(24) = 0
         DO i = 1 , 22
            idpdg = IPHO_ID2PDG(i)

            XM_list(i) = PYMASS(idpdg)

         END DO
         MSTj(24) = mstj24
         RETURN
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(1x,a,2i4)')
     &         'pho_pmass: invalid arguments (ID,mode): ' , Id , Mode
         RETURN
      END IF

      IF ( (i.EQ.0) .OR. (ABS(i).GT.ID_pdg_max) ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1x,a,2i8)')
     &         'pho_pmass: invalid arguments (ID,mode): ' , Id , Mode
         PHO_PMASS = 1.D0/DBLE(i)
         RETURN
      END IF

      PHO_PMASS = XM_list(ABS(i))

      END FUNCTION


        SUBROUTINE UMD2F0 (N, NZ, CP, XX, XSIZE, II, ISIZE, XTAIL,
     $          ITAIL, IUSE, XUSE, NZOFF, NBLKS, ICNTL, CNTL, INFO,
     $          RINFO, PRESRV, AP, AI, AX, AN, ANZ, KEEP, NE)
        INTEGER N, NZ, ISIZE, II (ISIZE), ICNTL (20), INFO (40),
     $          CP (N+1), XSIZE, XTAIL, ITAIL, IUSE, XUSE, AN, ANZ,
     $          AP (AN+1), AI (ANZ), KEEP (20), NZOFF, NBLKS, NE
        LOGICAL PRESRV
        DOUBLE PRECISION
     $          XX (XSIZE), AX (ANZ)
        DOUBLE PRECISION
     $          CNTL (10), RINFO (20)

C=== UMD2F0 ============================================================
C
C  Unsymmetric-pattern MultiFrontal Package (UMFPACK). Version 2.2d
C  Copyright (C) 1997, Timothy A. Davis, University of Florida, USA.
C  ALL RIGHTS RESERVED.
C  Joint work with Iain S. Duff, Rutherford Appleton Laboratory, UK.
C  July 7, 1997. Work supported by the National Science Foundation
C  (DMS-9223088 and DMS-9504974) and the State of Florida; and by CRAY
C  Research Inc. through the allocation of supercomputing resources.

C***********************************************************************
C* NOTICE:  "The UMFPACK Package may be used SOLELY for educational,   *
C* research, and benchmarking purposes by non-profit organizations and *
C* the U.S. government.  Commercial and other organizations may make   *
C* use of UMFPACK SOLELY for benchmarking purposes only.  UMFPACK may  *
C* be modified by or on behalf of the User for such use but at no time *
C* shall UMFPACK or any such modified version of UMFPACK become the    *
C* property of the User.  UMFPACK is provided without warranty of any  *
C* kind, either expressed or implied.  Neither the Authors nor their   *
C* employers shall be liable for any direct or consequential loss or   *
C* damage whatsoever arising out of the use or misuse of UMFPACK by    *
C* the User.  UMFPACK must not be sold.  You may make copies of        *
C* UMFPACK, but this NOTICE and the Copyright notice must appear in    *
C* all copies.  Any other use of UMFPACK requires written permission.  *
C* Your use of UMFPACK is an implicit agreement to these conditions."  *
C*                                                                     *
C* The MA38 Package in Release 12 of the Harwell Subroutine Library    *
C* (HSL) has equivalent functionality (and identical calling interface)*
C* as UMFPACK (the HSL has single and double precision versions only,  *
C* however).  It is available for commercial use.   Technical reports, *
C* information on HSL, and matrices are available via the World Wide   *
C* Web at http://www.cis.rl.ac.uk/struct/ARCD/NUM.html, or by          *
C* anonymous ftp at seamus.cc.rl.ac.uk/pub.  Also contact Dr. Scott    *
C* Roberts, Harwell Subroutine Library, B 552, AEA Technology,         *
C* Harwell, Didcot, Oxon OX11 0RA, England.                            *
C* telephone (44) 1235 434988, fax (44) 1235 434136                    *
C* email Scott.Roberts@aeat.co.uk, who will provide details of price   *
C* and conditions of use.                                              *
C***********************************************************************

C=======================================================================
C  NOT USER-CALLABLE.

C=======================================================================
C  DESCRIPTION:
C=======================================================================
C
C  Factorize an unsymmetric sparse matrix in column-form, optionally
C  permuting the matrix to upper block triangular form and factorizing
C  each diagonal block.

C=======================================================================
C  INPUT:
C=======================================================================
C
C       n:              order of matrix
C       nz:             entries in matrix, after removing duplicates
C                       and invalid entries.
C       ne:             number of triplets, unchanged from UMD2FA
C       Cp (1..n+1):    column pointers of input matrix
C       presrv:         if true then preserve original matrix
C       xsize:          size of XX
C       isize:          size of II
C       iuse:           memory usage in Index on input
C       xuse:           memory usage in Value on input
C       Icntl:          integer control parameters, see UMD21I
C       Cntl:           real control parameters, see UMD21I
C       Keep (6..8):    integer control parameters, see UMD21I
C
C       if presrv is true:
C           an:                 = n, order of preserved matrix
C           anz:                = anz, order of preserved matrix
C           Ap (1..an+1):       column pointers of preserved matrix
C           Ai (1..nz):         row indices of preserved matrix
C           Ax (1..nz):         values of preserved matrix
C           II:                 unused on input
C           XX:                 unused on input
C       else
C           an:                 1
C           anz:                1
C           Ap:                 unused
C           Ai:                 unused
C           Ax:                 unused
C           II (1..nz):         row indices of input matrix
C           XX (1..nz):         values of input matrix

C=======================================================================
C  OUTPUT:
C=======================================================================
C
C       XX (xtail ... xsize), xtail:
C
C                       LU factors are located in XX (xtail ... xsize),
C                       including values in off-diagonal part if matrix
C                       was permuted to block triangular form.
C
C       II (itail ... isize), itail:
C
C                       LU factors are located in II (itail ... isize),
C                       including pattern, row and column permutations,
C                       block triangular information, etc.  See umf2fa
C                       for more information.
C
C       Info:           integer informational output, see UMD2FA
C       Rinfo:          real informational output, see UMD2FA
C
C       iuse:           memory usage in Index on output
C       xuse:           memory usage in Value on output
C
C       nzoff:          entries in off-diagonal part (0 if BTF not used)
C       nblks:          number of diagonal blocks (1 if BTF not used)

C=======================================================================
C  SUBROUTINES AND FUNCTIONS CALLED / CALLED BY:
C=======================================================================
C
C       called by subroutine:   UMD2FA
C       subroutines called:     UMD2ER, UMD2FB, UMD2F1, UMD2OF
C       functions called:       MAX
        INTRINSIC MAX

C=======================================================================
C  LOCAL SCALARS:
C=======================================================================

        INTEGER KN, NZDIA, BLKPP, LUBLPP, P, OFFIP, XHEAD, ROW,
     $          OFFXP, OFFPP, IHEAD, K1, K2, BLK, PRP, P2, CPERMP,
     $          RPERMP, NSGLTN, NPIV, MNZ, NSYM, K, COL, RMAX, CMAX,
     $          TOTNLU, XRMAX, XRUSE
        LOGICAL TRYBTF, IOUT, XOUT
        DOUBLE PRECISION
     $          A

C  Allocated array pointers:
C  -------------------------
C  blkpp:   Blkp (1..nblks+1) array located in II (blkpp..blkp+nblks)
C  lublpp:  LUblkp (1..nblks) array loc. in II (lublpp..lublpp+nblks-1)
C  offip:   Offi (1..nzoff) array located in II (offip..offip+nzoff-1)
C  offxp:   Offx (1..nzoff) array located in XX (offxp..offxp+nzoff-1)
C  offpp:   Offp (1..n+1) array located in II (offpp..offpp+n)
C  cpermp:  Cperm (1..n) array located in II (cpermp..cpermp+n-1)
C  rpermp:  Rperm (1..n) array located in II (rpermp..rpermp+n-1)
C  prp:     Pr (1..n) work array located in II (prp..prp+n-1)
C
C  BTF information:
C  ----------------
C  k1:      starting index of diagonal block being factorized
C  k2:      ending index of diagonal block being factorized
C  kn:      the order of the diagonal block being factorized
C  blk:     block number of diagonal block being factorized
C  trybtf:  true if BTF is to be attempted (= Icntl (4) .eq. 1)
C  nzdia:   number of entries in diagonal blocks (= nz if BTF not used)
C  nsgltn:  number of 1-by-1 diagonal blocks ("singletons")
C  npiv:    number of numerically valid singletons
C  a:       numerical value of a singleton
C  mnz:     nzoff
C
C  Memory usage:
C  -------------
C  xhead:   XX (1..xhead-1) is in use, XX (xhead..xtail-1) is free
C  ihead:   II (1..ihead-1) is in use, II (ihead..itail-1) is free
C  iout:    true if UMD2F1 ran out of integer memory, but did not
C           set error flag
C  xout:    true if UMD2F2 ran out of integer memory, but did not
C           set error flag
C
C  Estimated memory for UMD2RF:
C  ----------------------------
C  rmax:    largest contribution block is cmax-by-rmax
C  cmax:       "         "         "    "   "   "  "
C  totnlu:  total number of LU arrowheads in all diagonal blocks
C  xrmax:   estimated maximum real memory usage for UMD2RF
C  xruse:   estimated current real memory usage for UMD2RF
C
C  Other:
C  ------
C  k:       loop index (kth pivot)
C  row:     row index
C  col:     column index
C  p:       pointer
C  p2:      pointer
C  nsym:    number of symmetric pivots chosen

C=======================================================================
C  EXECUTABLE STATEMENTS:
C=======================================================================

C-----------------------------------------------------------------------
C  get input parameters and initialize
C-----------------------------------------------------------------------

********************************************************************************
***  Minor bug fix, that was in Version 2.2 (and in MA38).  Jan. 20, 1998. *****
***  XOUT and IOUT need to be initialized.  They are set in UMD2FB, but that ***
***  routine is not called if the BTF is turned on (default) and the matrix ****
***  is permutable to upper *triangular* form.  In this case, XOUT and IOUT ****
***  are uninitialized, but used at statement 9000.  Fixed for Version 2.2.1, **
***  by adding the following two lines: ****************************************
********************************************************************************
        XOUT = .FALSE.
        IOUT = .FALSE.
********************************************************************************

        NBLKS = 1
        NZOFF = 0
        NZDIA = NZ
        NSGLTN = 0
        NPIV = 0
        RMAX = 1
        CMAX = 1
        TOTNLU = 0
        IF (PRESRV) THEN
C          original matrix is not in Cp/II/XX, but in Ap/Ai/Ax:
           IHEAD = 1
           XHEAD = 1
        ELSE
           IHEAD = NZ + 1
           XHEAD = NZ + 1
        ENDIF
        ITAIL = ISIZE + 1
        XTAIL = XSIZE + 1

C-----------------------------------------------------------------------
C  allocate permutation arrays: Cperm (1..n) and Rperm (1..n), and
C  seven scalars:  transa, nzoff, nblks, presrv, nz, n, ne
C  (in that order) at tail of II (in LU factors)
C-----------------------------------------------------------------------

        ITAIL = ITAIL - (2*N+7)
        IUSE = IUSE + (2*N+7)
        INFO (18) = MAX (INFO (18), IUSE)
        INFO (19) = INFO (18)
        CPERMP = ITAIL
        RPERMP = CPERMP + N
        IF (IHEAD .GT. ITAIL) THEN
C          error return, if not enough integer memory:
           GO TO 9000
        ENDIF

C-----------------------------------------------------------------------
C  Find permutations to block upper triangular form, if requested.
C-----------------------------------------------------------------------

        TRYBTF = ICNTL (4) .EQ. 1
        IF (TRYBTF) THEN

C          -------------------------------------------------------------
C          get workspace at tail of II of size 6n+2
C          -------------------------------------------------------------

           ITAIL = ITAIL - (N+1)
           OFFPP = ITAIL
           ITAIL = ITAIL - (5*N+1)
           P = ITAIL
           IUSE = IUSE + (6*N+2)
           INFO (18) = MAX (INFO (18), IUSE)
           INFO (19) = INFO (18)

C          -------------------------------------------------------------
           IF (PRESRV) THEN
C          find permutation, but do not convert to BTF form
C          -------------------------------------------------------------

              IF (IHEAD .GT. ITAIL) THEN
C                error return, if not enough integer memory:
                 GO TO 9000
              ENDIF
              CALL UMD2FB (AX, ANZ, AI, ANZ, N, NZ, NZDIA, NZOFF,
     $           NBLKS, CP, II (CPERMP), II (RPERMP), II(P), II(P+N),
     $           II (P+2*N), II (P+3*N), II (P+4*N), II (OFFPP),
     $           PRESRV, ICNTL)

C          -------------------------------------------------------------
           ELSE
C          find permutation, convert to BTF form, and discard original
C          -------------------------------------------------------------

C             use additional size nz temporary workspace in II and XX
              IHEAD = IHEAD + NZ
              XHEAD = XHEAD + NZ
              IUSE = IUSE + NZ
              XUSE = XUSE + NZ
              INFO (18) = MAX (INFO (18), IUSE)
              INFO (20) = MAX (INFO (20), XUSE)
              INFO (19) = INFO (18)
              INFO (21) = INFO (20)
              IF (IHEAD .GT. ITAIL .OR. XHEAD .GT. XTAIL) THEN
C                error return, if not enough integer and/or real memory:
                 GO TO 9000
              ENDIF
              CALL UMD2FB (XX, 2*NZ, II, 2*NZ, N, NZ, NZDIA, NZOFF,
     $              NBLKS, CP, II (CPERMP), II (RPERMP), II(P), II(P+N),
     $              II (P+2*N), II (P+3*N), II (P+4*N), II (OFFPP),
     $              PRESRV, ICNTL)
C             deallocate extra workspace in II and XX
              IHEAD = IHEAD - NZ
              XHEAD = XHEAD - NZ
              IUSE = IUSE - NZ
              XUSE = XUSE - NZ
           ENDIF

C          -------------------------------------------------------------
C          deallocate workspace, and allocate BTF arrays if required
C          -------------------------------------------------------------

           IF (NBLKS .GT. 1) THEN
C             replace (6*n+2) workspace at tail of II with
C             Blkp (1..nblks+1) and LUblkp (1..nblks), Offp (1..n+1)
              BLKPP = OFFPP - (NBLKS+1)
              LUBLPP = BLKPP - (NBLKS)
              ITAIL = LUBLPP
              IUSE = IUSE - (6*N+2) + (2*NBLKS+N+2)
           ELSE
C             The matrix is irreducible.  There is only one block.
C             Remove everything at tail of II, except
C             for the 2*n permutation vectors and the 7 scalars.
C             (transa, nzoff, nblks, presrv, nz, n, ne).
              ITAIL = (ISIZE + 1) - (2*N+7)
              IUSE = IUSE - (6*N+2)
           ENDIF

        ENDIF

C-----------------------------------------------------------------------
C current memory usage:
C-----------------------------------------------------------------------

C       if .not. presrv then
C               input matrix is now in II (1..nz) and XX (1..nz)
C               off-diagonal part: in II/XX (1..nzoff)
C                       col pattern: II (Offp (col) ... Offp (col+1))
C                       col values:  XX (Offp (col) ... Offp (col+1))
C               diagonal blocks: in II/XX (nzoff+1..nz)
C                       col pattern: II (Cp (col) ... Cp (col+1))
C                       col values:  XX (Cp (col) ... Cp (col+1))
C               total: nz+n+1 integers, nz reals
C       else
C               input matrix is now in Ai (1..nz) and Ax (1..nz),
C               in original (non-BTF) order:
C                       col pattern: Ai (Ap (col) ... Ap (col+1))
C                       col values:  Ax (Ap (col) ... Ap (col+1))
C               Cp is a size n+1 integer workspace
C               total: nz+2*(n+1) integers, nz reals
C
C       if (nblks > 1) then
C               at tail of II (in order): 2*nblks+n+2
C                       LUblkp (1..nblks)
C                       Blkp (1..nblks+1)
C                       Offp (1..n+1)
C               total: (2*nblks+n+2) integers
C
C       remainder at tail of II:
C               Cperm (1..n)
C               Rperm (1..n)
C               seven scalars: transa, nzoff, nblks, presrv, nz, n, ne
C
C   Grand total current memory usage (including II,XX,Cp,Ai,Ap,Ax):
C
C       presrv  nblks>1         integers, iuse =
C       F       F               nz+  (n+1)+(2*n+7)
C       F       T               nz+  (n+1)+(2*n+7)+(2*nblks+n+2)
C       T       F               nz+2*(n+1)+(2*n+7)
C       T       T               nz+2*(n+1)+(2*n+7)+(2*nblks+n+2)
C
C   real usage is xuse = nz

C       ----------------------------------------------------------------
C       get memory usage for next call to UMD2RF
C       ----------------------------------------------------------------

        XRMAX = 2*NE
        XRUSE = NZ

C-----------------------------------------------------------------------
C factorization
C-----------------------------------------------------------------------

        IF (NBLKS .EQ. 1) THEN

C          -------------------------------------------------------------
C          factorize the matrix as a single block
C          -------------------------------------------------------------

           CALL UMD2F1 (CP, N, II (CPERMP), II (RPERMP), NZOFF,
     $          ITAIL, XTAIL, XX, XSIZE, XUSE, II, ITAIL-1, IUSE,
     $          ICNTL, CNTL, INFO, RINFO, NBLKS,
     $          AP, AI, AX, PRESRV, 1, AN, ANZ, II, KEEP,
     $          RMAX, CMAX, TOTNLU, XRMAX, XRUSE, IOUT, XOUT)
           IF (IOUT .OR. XOUT) THEN
C             error return, if not enough integer and/or real memory:
              GO TO 9000
           ENDIF
           IF (INFO (1) .LT. 0) THEN
C             error return, if error in UMD2F2:
              GO TO 9010
           ENDIF
C          original matrix has been deallocated
           IHEAD = 1
           XHEAD = 1

C          -------------------------------------------------------------
C          make the index of the block relative to start of LU factors
C          -------------------------------------------------------------

           II (ITAIL) = 1

        ELSE

C          -------------------------------------------------------------
C          factorize the block-upper-triangular form of the matrix
C          -------------------------------------------------------------

           PRP = OFFPP
           IF (PRESRV) THEN
C             count the off-diagonal entries during factorization
              NZOFF = 0
C             compute temp inverse permutation in II (prp..prp+n-1)
CFPP$ NODEPCHK L
              DO 10 K = 1, N
                 II (PRP + II (RPERMP+K-1) - 1) = K
10            CONTINUE
           ENDIF

           DO 30 BLK = NBLKS, 1, -1

C             ----------------------------------------------------------
C             factorize the kn-by-kn block, A (k1..k2, k1..k2)
C             ----------------------------------------------------------

C             get k1 and k2, the start and end of this block
              K1 = II (BLKPP+BLK-1)
              K2 = II (BLKPP+BLK) - 1
              KN = K2-K1+1
              IF (.NOT. PRESRV) THEN
                 P = CP (K1)
                 CP (K2+1) = IHEAD
              ENDIF

              IF (KN .GT. 1) THEN

C                -------------------------------------------------------
C                factor the block (the block is not a singleton)
C                -------------------------------------------------------

                 CALL UMD2F1 (CP (K1), KN,
     $              II (CPERMP+K1-1), II (RPERMP+K1-1), NZOFF,
     $              ITAIL, XTAIL, XX, XTAIL-1, XUSE, II, ITAIL-1,
     $              IUSE, ICNTL, CNTL, INFO, RINFO, NBLKS,
     $              AP, AI, AX, PRESRV, K1, AN, ANZ, II (PRP), KEEP,
     $              RMAX, CMAX, TOTNLU, XRMAX, XRUSE, IOUT, XOUT)
                 IF (IOUT .OR. XOUT) THEN
C                   error return, if not enough int. and/or real memory:
                    GO TO 9000
                 ENDIF
                 IF (INFO (1) .LT. 0) THEN
C                   error return, if error in UMD2F2:
                    GO TO 9010
                 ENDIF
                 IF (PRESRV) THEN
                    IHEAD = 1
                    XHEAD = 1
                 ELSE
                    IHEAD = P
                    XHEAD = P
                 ENDIF

C                -------------------------------------------------------
C                save the location of the LU factors in LUbkp (blk)
C                -------------------------------------------------------

                 II (LUBLPP+BLK-1) = ITAIL

              ELSE

C                -------------------------------------------------------
C                get the value of singleton at A (k1,k1), if it exists
C                -------------------------------------------------------

                 A = 0
                 IF (PRESRV) THEN
C                   find the diagonal entry in the unpermuted matrix
                    COL = II (CPERMP + K1 - 1)
                    DO 20 P2 = AP (COL), AP (COL + 1) - 1
                       ROW = II (PRP + AI (P2) - 1)
                       IF (ROW .LT. K1) THEN
C                         entry in off-diagonal blocks
                          NZOFF = NZOFF + 1
                       ELSE
                          A = AX (P2)
                       ENDIF
20                  CONTINUE
                    IHEAD = 1
                    XHEAD = 1
                 ELSE IF (P .NE. IHEAD) THEN
                    A = XX (P)
                    IHEAD = P
                    XHEAD = P
                    IUSE = IUSE - 1
                    XUSE = XUSE - 1
                    XRUSE = XRUSE - 1
                 ENDIF

C                -------------------------------------------------------
C                store the 1-by-1 LU factors of a singleton
C                -------------------------------------------------------

                 NSGLTN = NSGLTN + 1
                 IF (ABS (A) .EQ. 0) THEN
C                   the diagonal entry is either not present, or present
C                   but numerically zero.  This is a singular matrix,
C                   replace with 1-by-1 identity matrix.
                    A = 1
                 ELSE
C                   increment pivot count
                    NPIV = NPIV + 1
                 ENDIF
                 XTAIL = XTAIL - 1
C                note: if the matrix is not preserved and nonsingular
C                then we will not run out of memory at this point.
                 XUSE = XUSE + 1
                 XRUSE = XRUSE + 1
                 XRMAX = MAX (XRMAX, XRUSE)
                 INFO (20) = MAX (INFO (20), XUSE)
                 INFO (21) = MAX (INFO (21), XUSE)
C                error return, if not enough real memory:
                 IF (XHEAD .GT. XTAIL) THEN
                    GO TO 9000
                 ENDIF
                 II (LUBLPP+BLK-1) = -XTAIL
                 XX (XTAIL) = A

              ENDIF

30         CONTINUE

C          -------------------------------------------------------------
C          make the index of each block relative to start of LU factors
C          -------------------------------------------------------------

CFPP$ NODEPCHK L
           DO 40 P = LUBLPP, LUBLPP + NBLKS - 1
              IF (II (P) .GT. 0) THEN
                 II (II (P)) = II (II (P)) - XTAIL + 1
                 II (P) = II (P) - ITAIL + 1
              ELSE
C                this is a singleton
                 II (P) = (-II (P)) - XTAIL + 1
              ENDIF
40         CONTINUE

C          -------------------------------------------------------------
C          allocate temporary workspace for Pr (1..n) at head of II
C          -------------------------------------------------------------

           PRP = IHEAD
           IHEAD = IHEAD + N
           IUSE = IUSE + N

C          -------------------------------------------------------------
C          allocate a single entry in case the LU factors are empty
C          -------------------------------------------------------------

           IF (NBLKS .EQ. N) THEN
C             otherwise, arrays in UMD2RF and UMD2SO would have
C             zero size, which can cause an address fault later on
              ITAIL = ITAIL - 1
              IUSE = IUSE + 1
              P2 = ITAIL
           ENDIF

C          -------------------------------------------------------------
C          allocate permanent copy of off-diagonal blocks
C          -------------------------------------------------------------

           ITAIL = ITAIL - NZOFF
           OFFIP = ITAIL
           XTAIL = XTAIL - NZOFF
           OFFXP = XTAIL
           IUSE = IUSE + NZOFF
           XUSE = XUSE + NZOFF
           XRUSE = XRUSE + NZOFF
           XRMAX = MAX (XRMAX, XRUSE)
           INFO (18) = MAX (INFO (18), IUSE)
           INFO (19) = MAX (INFO (19), IUSE)
           INFO (20) = MAX (INFO (20), XUSE)
           INFO (21) = MAX (INFO (21), XUSE)
           IF (IHEAD .GT. ITAIL .OR. XHEAD .GT. XTAIL) THEN
C             error return, if not enough integer and/or real memory:
              GO TO 9000
           ENDIF

C          -------------------------------------------------------------
C          re-order the off-diagonal blocks according to pivot perm
C          -------------------------------------------------------------

C          use Cp as temporary work array:
           MNZ = NZOFF
           IF (PRESRV) THEN
              CALL UMD2OF (CP, N, II (RPERMP), II (CPERMP), NZOFF,
     $          II (OFFPP), II (OFFIP), XX (OFFXP), II (PRP),
     $          ICNTL, AP, AI, AX, AN, ANZ, PRESRV, NBLKS, II (BLKPP),
     $          MNZ, 1, INFO, P)
           ELSE
              CALL UMD2OF (CP, N, II (RPERMP), II (CPERMP), NZOFF,
     $          II (OFFPP), II (OFFIP), XX (OFFXP), II (PRP),
     $          ICNTL, 0, II, XX, 0, MNZ, PRESRV, 0, 0,
     $          MNZ, 1, INFO, P)
           ENDIF
           IF (NBLKS .EQ. N) THEN
C             zero the only entry in the integer part of the LU factors
              II (P2) = 0
           ENDIF

C          -------------------------------------------------------------
C          deallocate Pr (1..n), and II/XX (1..nzoff) if present
C          -------------------------------------------------------------

           IHEAD = 1
           XHEAD = 1
           IUSE = IUSE - N
           IF (.NOT. PRESRV) THEN
              IUSE = IUSE - NZOFF
              XUSE = XUSE - NZOFF
           ENDIF

        ENDIF

C-----------------------------------------------------------------------
C  normal and error return
C-----------------------------------------------------------------------

C       error return label:
9000    CONTINUE
        IF (IOUT .OR. IHEAD .GT. ITAIL) THEN
C          set error flag if not enough integer memory
           CALL UMD2ER (1, ICNTL, INFO, -3, INFO (19))
        ENDIF
        IF (XOUT .OR. XHEAD .GT. XTAIL) THEN
C          set error flag if not enough real memory
           CALL UMD2ER (1, ICNTL, INFO, -4, INFO (21))
        ENDIF

C       error return label, for error from UMD2F2:
9010    CONTINUE

        INFO (4) = 0
        NZDIA = NZ - NZOFF
        INFO (5) = NZ
        INFO (6) = NZDIA
        INFO (7) = NZOFF
        INFO (8) = NSGLTN
        INFO (9) = NBLKS
        INFO (12) = INFO (10) + INFO (11) + N + INFO (7)

C       Count the number of symmetric pivots chosen.  Note that some of
C       these may have been numerically unacceptable.
        NSYM = 0
        IF (INFO (1) .GE. 0) THEN
           DO 50 K = 1, N
              IF (II (CPERMP+K-1) .EQ. II (RPERMP+K-1)) THEN
C                this kth pivot came from the diagonal of A
                 NSYM = NSYM + 1
              ENDIF
50         CONTINUE
        ENDIF
        INFO (16) = NSYM

        INFO (17) = INFO (17) + NPIV
        RINFO (1) = RINFO (4) + RINFO (5) + RINFO (6)

        IF (INFO (1) .GE. 0 .AND. INFO (17) .LT. N) THEN
C          set warning flag if matrix is singular
           CALL UMD2ER (1, ICNTL, INFO, 4, INFO (17))
        ENDIF

C       ----------------------------------------------------------------
C       Determine an upper bound on the amount of integer memory needed
C       (LINDEX) for a subsequent call to UMD2RF.  If block-upper-
C       triangular-form is not in use (Info (9) is 1), then
C       this bound is exact.  If NE is higher in the call to UMD2RF
C       than in the call to UMD2FA, then add 3 integers for each
C       additional entry (including the 2 integers required for the
C       row and column indices of the additional triplet itself).
C       This estimate assumes that JOB and TRANSA are the same in
C       UMD2FA and UMD2RF.
C       ----------------------------------------------------------------

C       (Keep (5) - Keep (4) + 1), is added to Info (22)
C       in UMD2FA, to complete the computation of the estimate.

        IF (PRESRV) THEN
           INFO (22) = MAX (3*NE+2*N+1, NE+3*N+2,
     $                           2*NZ+4*N+10+RMAX+3*CMAX+4*TOTNLU)
        ELSE
           INFO (22) = MAX (3*NE+2*N+1, NE+3*N+2, 2*NZ+3*N+2,
     $                             NZ+3*N+ 9+RMAX+3*CMAX+4*TOTNLU)
        ENDIF

C       ----------------------------------------------------------------
C       Approximate the amount of real memory needed (LVALUE) for a
C       subsequent call to UMD2RF.  The approximation is an upper bound
C       on the bare minimum amount needed.  Some garbage collection may
C       occur, but UMD2RF is guaranteed to finish if given an LVALUE of
C       size Info (23) and if the pattern is the same.  If NE is
C       higher in the call to UMD2RF than in the call to UMD2FA, then
C       add 2 reals for each additional entry (including the 1 real
C       required for the value of the additional triplet itself).
C       This estimate assumes that JOB and TRANSA are the same in
C       UMD2FA and UMD2RF.
C       ----------------------------------------------------------------

        INFO (23) = XRMAX
        RETURN
        END