!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Chemistry module of UCL_CHEM.                                                               !
! Contains all the core machinery of the code, not really intended to be altered in standard  !
! use. Use a (custom) physics module to alter temp/density behaviour etc.                     !
!                                                                                !
! chemistry module contains rates.f90, a series of subroutines to calculate all reaction rates!
! when updateChemistry is called from main, these rates are calculated, the ODEs are solved   !
! from currentTime to targetTime to get abundances at targetTime and then all abundances are  !
! written to the fullOutput file.                                                             !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE chemistry
USE physics
USE dvode_f90_m
USE network
IMPLICIT NONE
   !These integers store the array index of important species and reactions, x is for ions
    integer :: nh,nh2,nc,ncx,no,nn,ns,nsx,nhe,nco,nmg,nf,nh2o,nsi,nsix,ncl,nclx,nch3oh,np
    integer :: nrco,njunk,evapevents,ngrainco,readAbunds
    !loop counters
    integer :: i,j,l,writeStep,writeCounter=0

    !Array to store reaction rates
    double precision :: rate(nreac)

    !Option column output
    character(LEN=15),allocatable :: outSpecies(:)
    logical :: columnFlag
    integer :: nout
    integer, allocatable :: outIndx(:)

    !DLSODE variables
    integer :: ITASK,ISTATE,NEQ,MXSTEP
    double precision :: reltol
    double precision, allocatable :: abstol(:)
    TYPE(VODE_OPTS) :: OPTIONS

    !initial fractional elemental abudances and arrays to store abundances
    double precision :: fh,fhe,fc,fo,fn,fs,fmg,fsi,fcl,fp,ff,h2col,cocol,junk1,junk2
    double precision,allocatable :: abund(:,:),mantle(:)

    !Variables controlling chemistry
    double precision :: radfield,zeta,fr,omega,grainArea,cion,h2form,h2dis
    double precision :: ebmaxh2,epsilon,ebmaxcrf,ebmaxcr,phi,ebmaxuvcr,uvy,uvcreff
    double precision, allocatable ::vdiff(:)

    !Variables for self-shielding of CO and H2
    !dopw = doppler width (in s-1) of a typical transition
    !(assuming turbulent broadening with beta=3e5cms-1)
    !radw = radiative line width of typ. transition (in s-1)
    !fosc = oscillator strength of a typical transition
    double precision  :: dopw=3.0e10,radw=8.0e07,xl=1000.0,fosc  = 1.0d-2,taud

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !variables for diffusion reactions on the grains, CGS unless otherwise stated.
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    LOGICAL, parameter :: DIFFUSE_REACT_COMPETITION=.True., GRAINS_HAVE_ICE=.True.
    double precision, parameter :: GAS_DUST_MASS_RATIO=100.0,REDUCED_PLANCK=1.054571628d-27,AMU=1.66053892d-24
    double precision, parameter :: K_BOLTZ=1.3806588d-16,GRAIN_AREA=2.4d-22,GRAIN_RADIUS=1.d-5
    double precision, parameter :: CHEMICAL_BARRIER_THICKNESS = 1.40d-8  !gre Parameter used to compute the probability for a surface reaction with
    !! activation energy to occur through quantum tunneling (Hasegawa et al. Eq 6 (1992).)
    double precision, parameter :: SURFACE_SITE_DENSITY = 1.5d15 ! site density on one grain [cm-2]
    double precision, parameter :: VDIFF_PREFACTOR=2.0*K_BOLTZ*SURFACE_SITE_DENSITY/PI/PI/AMU
    double precision, parameter :: GRAIN_DENSITY = 3.0 ! Mass density of a dust grain
    double precision, parameter :: NUM_SITES_PER_GRAIN = GRAIN_RADIUS*GRAIN_RADIUS*SURFACE_SITE_DENSITY*4.0*PI
    double precision, parameter :: GAS_DUST_DENSITY_RATIO = (4.0*PI*(GRAIN_RADIUS**3)*GRAIN_DENSITY*GAS_DUST_MASS_RATIO)/(3.0 * AMU)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !CO and H2 self-shielding
    !Used by functions in rates.f90
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    logical :: startr=.True.
    integer,parameter :: dimco=7, dimh2=6
    double precision :: corates(7,6)=reshape((/0.000d+00, -1.408d-02, -1.099d-01, -4.400d-01,&
     &  -1.154d+00, -1.888d+00, -2.760d+00,&
     &  -8.539d-02, -1.015d-01, -2.104d-01, -5.608d-01,&
     &  -1.272d+00, -1.973d+00, -2.818d+00,&
     &  -1.451d-01, -1.612d-01, -2.708d-01, -6.273d-01,&
     &  -1.355d+00, -2.057d+00, -2.902d+00,&
     &  -4.559d-01, -4.666d-01, -5.432d-01, -8.665d-01,&
     &  -1.602d+00, -2.303d+00, -3.146d+00,&
     &  -1.303d+00, -1.312d+00, -1.367d+00, -1.676d+00,&
     &  -2.305d+00, -3.034d+00, -3.758d+00,&
     &  -3.883d+00, -3.888d+00, -3.936d+00, -4.197d+00,&
     &  -4.739d+00, -5.165d+00, -5.441d+00 /),shape(corates))
    double precision :: y2r(7,6)
    double precision :: ncogr(dimco) =(/12.0d+00, 13.0d+00, 14.0d+00, 15.0d+00,&
      &16.0d+00, 17.0d+00, 18.0d+00 /)
    double precision :: nh2gr(dimh2)=(/18.0d+00, 19.0d+00, 20.0d+00, 21.0d+00,&
       &22.0d+00, 23.0d+00 /)
CONTAINS
!This gets called immediately by main so put anything here that you want to happen before the time loop begins, reader is necessary.
    SUBROUTINE initializeChemistry
        NEQ=nspec+1
        IF (ALLOCATED(abund)) DEALLOCATE(abund,vdiff,mantle)
        ALLOCATE(abund(NEQ,points),vdiff(nspec))
        CALL reader
        !if this is the first step of the first phase, set initial abundances
        !otherwise reader will fix it
        IF (readAbunds.eq.0) THEN
            !ensure abund is initially zero
            abund= 0.
            !As default, have half in molecular hydrogen and half in atomic hydrogen
            abund(nh2,:) = 0.5*(0.5*(1.0e0-fh))
            abund(nh,:) = (0.5*(1.0e0-fh))
            abund(nhe,:) = fhe
            abund(no,:) = fo
            abund(nn,:) = fn
            abund(nsx,:) = fs
            abund(nmg,:) = fmg
            abund(nsix,:) = fsi
            abund(nclx,:) = fcl
            !abund(np,:) = fp
            !abund(nf,:) = ff

            !abund(nfe,:) = ffe
            !abund(nna,:) = fna
            abund(nspec+1,:)=density

            !Decide how much iron is initiall ionized using parameters.f90
            SELECT CASE (ion)
                CASE(0)
                    abund(nc,:)=fc
                    abund(ncx,:)=1.d-10
                CASE(1)
                    abund(nc,:)=fc*0.5
                    abund(ncx,:)=fc*0.5
                CASE(2)
                    abund(nc,:)=1.d-10
                    abund(ncx,:)=fc
            END SELECT
            abund(nspec,:)=abund(ncx,:)+abund(nsix,:)+abund(nsx,:)+abund(nclx,:)

        ENDIF
        !Initial calculations of diffusion frequency for each species bound to grain
        !and other parameters required for diffusion reactions
        DO  i=lbound(grainList,1),ubound(grainList,1)
            j=grainList(i)
            vdiff(i)=VDIFF_PREFACTOR*bindingEnergy(i)/mass(j)
            vdiff(i)=dsqrt(vdiff(i))
        END DO

        !h2 formation rate initially set
        h2form = 1.0d-17*dsqrt(initialTemp)
        ALLOCATE(mantle(points))
        DO l=1,points
            mantle(l)=sum(abund(grainList,l))
        END DO

        !DVODE SETTINGS
        ISTATE=1;;ITASK=1
        reltol=1e-4;MXSTEP=10000

        IF (.NOT. ALLOCATED(abstol)) THEN
            ALLOCATE(abstol(NEQ))
        END IF
        !OPTIONS = SET_OPTS(METHOD_FLAG=22, ABSERR_VECTOR=abstol, RELERR=reltol,USER_SUPPLIED_JACOBIAN=.FALSE.)

    END SUBROUTINE initializeChemistry

!Reads input reaction and species files as well as the final step of previous run if this is phase 2
    SUBROUTINE reader
        IMPLICIT NONE
        integer i,j,l,m
        double precision junktemp

        IF (ALLOCATED(outIndx)) DEALLOCATE(outIndx)
        IF (columnFlag) THEN
            nout = SIZE(outSpecies)
            ALLOCATE(outIndx(nout))
        END IF
        !assign array indices for important species to the integers used to store them.
        DO i=1,nspec
            IF (specname(i).eq.'H')   nh  = i
            IF (specname(i).eq.'H2')  nh2 = i
            IF (specname(i).eq.'C')   nc  = i
            IF (specname(i).eq.'C+')  ncx = i
            IF (specname(i).eq.'O')   no  = i
            IF (specname(i).eq.'N')   nn  = i
            IF (specname(i).eq.'S+')  nsx  = i
            IF (specname(i).eq.'HE')  nhe = i
            IF (specname(i).eq.'CO')  nco = i
            IF (specname(i).eq.'MG')  nmg = i
            IF (specname(i).eq.'H2O') nh2o = i
            IF (specname(i).eq.'SI')  nsi = i
            IF (specname(i).eq.'SI+') nsix= i
            IF (specname(i).eq.'CL')  ncl = i
            IF (specname(i).eq.'CL+') nclx= i
            IF (specname(i).eq.'CH3OH') nch3oh= i
            IF (specname(i).eq.'#CO') ngrainco = i
            IF (specname(i).eq. 'P') np=i
            IF (specname(i).eq.'F') nf=i
            IF (columnFlag) THEN
                DO j=1,nout
                    IF (specname(i).eq.outSpecies(j)) outIndx(j)=i
                END DO
            END IF
        END DO

        !read start file if choosing to use abundances from previous run
        !
        IF (readAbunds .eq. 1) THEN
            DO l=1,points
                READ(7,*)
                READ(7,7000) abund(nspec+1,l),junktemp,av(l)
                READ(7,*)
                READ(7,7010) h2form,fc,fo,&
                            &fmg,fhe,dstep
                READ(7,*)
                READ(7,7030) (abund(i,l),i=1,nspec)
                REWIND(7)
                abund(nspec+1,l)=density(l)
            END DO
            7000 format(&
            &33x,1pe10.4,5x,/,&
            &33x,0pf8.2,2x,/,&
            &33x,0pf12.4,4x,/)
            7010 format(&
            &33x,1pe8.2,8x,/,&
            &11x,1pe7.1,4x,12x,1pe7.1,/&
            &12x,1pe7.1,13x,1pe7.1,&
            &13x,i3,/)
            7020  format(//)
            7030  format(4(18x,1pe10.3,:))
        END IF
    END SUBROUTINE reader

!Writes physical variables and fractional abundances to output file, called every time step.
    SUBROUTINE output
        !write out cloud properties
        write(10,8020) timeInYears,density(dstep),temp(dstep),av(dstep),radfield,zeta,h2form,fc,fo,&
                        &fmg,fhe,dstep
        !and a blank line
        write(10,8000)
        !and then all the abundances for this step
        write(10,8010) (specname(i),abund(i,dstep),i=1,nspec)
        write(10,8000)
        !If this is the last time step of phase I, write a start file for phase II
        IF (readAbunds .eq. 0) THEN
           IF (switch .eq. 0 .and. timeInYears .ge. finalTime&
               &.or. switch .eq. 1 .and.density(dstep) .ge. finalDens) THEN
               write(7,8020) timeInYears,density(dstep),temp(dstep),av(dstep),radfield,zeta,h2form,fc,fo,&
                       &fmg,fhe,dstep
               write(7,8000)
               write(7,8010) (specname(i),abund(i,dstep),i=1,nspec)
               write(7,8000)
           ENDIF
        ENDIF
        8000  format(/)
        8010  format(4(1x,a15,'=',1x,1pe10.3,:))
        8020 format(&
        &'age of cloud             time  = ',1pe10.3,' years',/,&
        &'total hydrogen density   dens  = ',1pe10.4,' cm-3',/,&
        &'cloud temperature        temp  = ',0pf8.2,' k',/,&
        &'visual extinction        av    = ',0pf12.4,' mags',/,&
        &'radiation field          rad   = ',0pf10.2,' (habing = 1)',/,&
        &'cosmic ray ioniz. rate   zeta  = ',0pf10.2,' (unit = 1.3e-17s-1)',/,&
        &'h2 formation rate coef.        = ',1pe8.2,' cm3 s-1',/,&
        &'c / htot = ',1pe7.1,4x,' o / htot = ',1pe7.1,/&
        &'mg / htot = ',1pe7.1,&
        &' he / htot = ',1pe7.1,&
        &' depth     = ',i3)

        !Every 'writestep' timesteps, write the chosen species out to separate file
        !choose species you're interested in by looking at parameters.f90
        IF (writeCounter==writeStep .and. columnFlag) THEN
            writeCounter=0
            write(11,8030) timeInYears,density(dstep),temp(dstep),abund(outIndx,dstep)
            8030  format(1pe11.3,1x,1pe11.4,1x,0pf8.2,6(1x,1pe10.3))
        ELSE
            writeCounter=writeCounter+1
        END IF
    END SUBROUTINE output

    SUBROUTINE updateChemistry
    !Called every time/depth step and updates the abundances of all the species
        !allow option for dens to have been changed elsewhere.
        IF (collapse .ne. 1) abund(nspec+1,dstep)=density(dstep)
        !y is at final value of previous depth iteration so set to initial values of this depth with abund
        !reset other variables for good measure
        h2form = 1.0d-17*dsqrt(temp(dstep))

        !Sum of abundaces of all mantle species. mantleindx stores the indices of mantle species.
        mantle(dstep)=sum(abund(grainList,dstep))
        !evaluate co and h2 column densities for use in rate calculations
        !sum column densities of each point up to dstep. boxlength and dens are pulled out of the sum as common factors
        IF (dstep.gt.1) THEN
            h2col=(sum(abund(nh2,:dstep-1)*density(:dstep-1))+0.5*abund(nh2,dstep)*density(dstep))*(cloudSize/real(points))
            cocol=(sum(abund(nco,:dstep-1)*density(:dstep-1))+0.5*abund(nco,dstep)*density(dstep))*(cloudSize/real(points))
        ELSE
            h2col=0.5*abund(nh2,dstep)*density(dstep)*(cloudSize/real(points))
            cocol=0.5*abund(nco,dstep)*density(dstep)*(cloudSize/real(points))
        ENDIF

        !call the actual ODE integrator
        CALL integrate

        !1.d-30 stops numbers getting too small for fortran.
        WHERE(abund<1.0d-30) abund=1.0d-30
        density(dstep)=abund(nspec+1,dstep)
    END SUBROUTINE updateChemistry

    SUBROUTINE integrate
    !This subroutine calls DVODE (3rd party ODE solver) until it can reach targetTime with acceptable errors (reltol/abstol)
        DO WHILE(currentTime .lt. targetTime)
            !reset parameters for DVODE
            ITASK=1 !try to integrate to targetTime
            ISTATE=1 !pretend every step is the first
            reltol=1e-4 !relative tolerance effectively sets decimal place accuracy
            abstol=1.0d-14*abund(:,dstep) !absolute tolerances depend on value of abundance
            WHERE(abstol<1d-30) abstol=1d-30 ! to a minimum degree

            !get reaction rates for this iteration
            CALL calculateReactionRates
            !Call the integrator.
            OPTIONS = SET_OPTS(METHOD_FLAG=22, ABSERR_VECTOR=abstol, RELERR=reltol,USER_SUPPLIED_JACOBIAN=.FALSE.,MXSTEP=MXSTEP)
            CALL DVODE_F90(F,NEQ,abund(:,dstep),currentTime,targetTime,ITASK,ISTATE,OPTIONS)
            SELECT CASE(ISTATE)
                CASE(-1)
                    !More steps required for this problem
                    MXSTEP=MXSTEP*2
                CASE(-2)
                    !Tolerances are too small for machine but succesful to current currentTime
                    abstol=abstol*10.0
                CASE(-3)
                    write(*,*) "DVODE found invalid inputs"
                    write(*,*) "abstol:"
                    write(*,*) abstol
                    STOP
                CASE(-4)
                    !Successful as far as currentTime but many errors.
                    !Make targetTime smaller and just go again
                    targetTime=currentTime+10.0*SECONDS_PER_YEAR
                CASE(-5)
                    targetTime=currentTime*1.01
            END SELECT
        END DO
    END SUBROUTINE integrate

    !This is where reacrates subroutine is hidden
    include 'rates.f90'

    SUBROUTINE  F (NEQ, T, Y, YDOT)
        INTEGER, PARAMETER :: WP = KIND(1.0D0)
        INTEGER NEQ
        REAL(WP) T
        REAL(WP), DIMENSION(NEQ) :: Y, YDOT
        INTENT(IN)  :: NEQ, T, Y
        INTENT(OUT) :: YDOT
        DOUBLE PRECISION :: D,loss,prod
        !Set D to the gas density for use in the ODEs
        D=y(NEQ)
        ydot=0.0
        !The ODEs created by MakeRates go here, they are essentially sums of terms that look like k(1,2)*y(1)*y(2)*dens. Each species ODE is made up
        !of the reactions between it and every other species it reacts with.
        INCLUDE 'odes.f90'

        !updated just in case temp changed
        h2form=1.0d-17*dsqrt(temp(dstep))

        !H2 formation should occur at both steps - however note that here there is no
        !temperature dependence. y(nh) is hydrogen fractional abundance.
        ydot(nh)  = ydot(nh) - 2.0*( h2form*y(nh)*D - h2dis*y(nh2) )
        !                             h2 formation - h2-photodissociation
        ydot(nh2) = ydot(nh2) + h2form*y(nh)*D - h2dis*y(nh2)
        !                       h2 formation  - h2-photodissociation

        ! get density change from physics module to send to DLSODE
        IF (collapse .eq. 1) ydot(NEQ)=densdot(y(NEQ))
    END SUBROUTINE F

    SUBROUTINE debugout
        open(79,file='output/debuglog',status='unknown')       !debug file.
        write(79,*) "Integrator failed, printing relevant debugging information"
        write(79,*) "dens",density(dstep)
        write(79,*) "density in integration array",abund(nspec+1,dstep)
        write(79,*) "Av", av(dstep)
        write(79,*) "Mantle", mantle(dstep)
        write(79,*) "Temp", temp(dstep)
        DO i=1,nreac
            if (rate(i) .ge. huge(i)) write(79,*) "Rate(",i,") is potentially infinite"
        END DO
    END SUBROUTINE debugout
END MODULE chemistry


C  Fortran AVS/Express module

C
C  Source for fortran function readStar_f
C
      integer function readStar_f(obj_id, mask, seq_num)
c#include "avs/omf.inc"
      include "avs/omf.inc"
      integer obj_id(OIDSIZ), mask, seq_num
C
C  Place your module's source code here
C
      integer tmp_id(OIDSIZ), fld_id(OIDSIZ)
C
C SET PARAMETERS ACCORDING TO PREPROCESSING PARAMETERS (SEE FILE PARAM.PRP)
C
C MAX NO. OF VERTICES
      PARAMETER (MAXVRT=    240000)
C MAX NO. OF CELLS
      PARAMETER (MAXCEL=    200000)
C MAX NO. OF SAMM CELLS
      PARAMETER (MAXSAM=      1)
C MAX NO. OF USER APPLIED BOUNDARIES
      PARAMETER (MAXNBU=     100000)
C MAX NO. OF CELL TABLE ENTRIES
      PARAMETER (MAXTAB=      600)
C MAX NO. OF COUPLED SETS
      PARAMETER (MAXNCP=      4000)
C THE LARGER BETWEEN MAXCEL AND MAXVRT
      PARAMETER (MAXPST=    500000)
C MAX NO. OF BOUNDARIES FOR ENTIRE MODEL (USER + DEFAULT)
      PARAMETER (MAXBND=     400000)
C MAX NO. OF BOUNDARY REGIONS
      PARAMETER (MAXREG=       500)
C MAX NO. OF ELEMENTS FOR SCRATCH ARRAY1
      PARAMETER (MAXSC1=    560000)
C MAX NO. OF ELEMENTS FOR SCRATCH ARRAY2
      PARAMETER (MAXSC2=   2732048)
C
      PARAMETER (NCYDIM=  51)
      PARAMETER (NCPDIM=  51)
C

      COMMON/NODES/C(3,MAXVRT)
      COMMON/CELLS/NE(9,MAXCEL)
      COMMON/SAMML/LSAMM,NLSAMM(MAXCEL)
      COMMON/SAMMC/NESAMM(13,MAXSAM)
      COMMON/BOUND/IBDS(6,0:MAXNBU)
      COMMON/REGTYP/IRTYPE(-1:MAXREG)
      COMMON/CTABLE/ICTAB(10,MAXTAB)
      COMMON/NTABLE/CTNAME(MAXTAB)
      COMMON/CYCLIC/ISCYC(NCYDIM,MAXNCP)
      COMMON/COUPLE/ICOUP(NCPDIM,MAXNCP)
      COMMON/PDATA/VECTOR(14,MAXPST)
      COMMON/POSTC/DENM(99),VISM(99),CPHM(99),CONDM(99)
C TWO SCRATCH BLOCKS SCRT1 AND SCRT2
      COMMON/SCRT1/DUM1(MAXSC1)
      COMMON/SCRT2/DUM2(MAXSC2)
C SCRT3 IS NCMAP
      COMMON/SCRT3/DUM3(MAXCEL)
      COMMON/PRINTS/NPRSRF(3),NPROBS
      COMMON/ARSIZE/MAXC,MAXV,MAXCP,MAXTB,MAXBU,MAXRU,MXPST
      COMMON/CASEN/CASE,TITLE
      COMMON/KEY/MAXN,MAXE,ICSYS,MAXSYS,ITYPE,PFIRST,IVERS,NUMW,
     1           NI,NJ,NK,NF,MAXB,IBFILL,NOVICE,KEYS(10),LW,LR,
     2           LECHO,LNUT,MXTB,LTURBI,LTURBP,SETADD,NSENS,NPART,
     4           SCALE8,KEYS2(18)
      COMMON/POSTD/ITERU,TIMEU,ITERS,TIMES,VMING,VMAXG,VMINL,VMAXL,
     1             SMING,SMAXG,SMINL,SMAXL,NDATA(200,3),LPOST,
     2             NCELL,NBC,NBW,NBS,NBB,NNODE,WPOST,LDCELL,LDVERT,
     3             LSORT,LUNMOD,IPSYS,LOPER,LRSKIP,TREF,LDSURF,
     4             ISRTAB,ICSH1,NSITEM,LSRF(200),NBCUT,NBCYC,PREF1,
     5             PREPP(2,99),NTCELL,LCNPST,LDPPRS,
     6             LPCORD,NUMCON,NSC,TREFM(99),LVERS,LDFLUX,
     7             IREFRM,IRESYS,OMEREF,ADDREL,PGRAV(7,99),PSPIN(7,99),
     8             PMW(99),PMWS(50,99),SCALE9,LPTYP,LADJST,LPINTP,TIMEP,
     9             ITERP,LRELA,LMVGR,NDATAP(200,3),IRETW,NWSET,SPCYC,
     *             LSTAR(100),NBNCST,NBNCEN,NBSI,NSCL,NREG,
     1             MRECMM,NBP23,NCLPS,NWPRSM,NPRSM,NCLP,NCLPF,ITYPEN
      DIMENSION ARR(2048),LARR(2048),NDUM(9)
      LOGICAL LSTAR,SPCYC,LRSKIP
      LOGICAL LARR,WPOST,FMTOUT,WELEM,WWALL,WBOUND
      CHARACTER CASE*70,ANS*1,OFILE*4,TITLE*52,ITEM*4,FNAME*80
      EQUIVALENCE (ARR,IARR,LARR)
c
      integer ndoffs(maxvrt)
      logical optset, lstset
      character pans*1, tans*1, trtype*1
      integer trstep
      double precision trtime
c
C
C FOR COMMON/ARSIZE/ USE
C
      LRSKIP=.FALSE.
      MAXC=MAXCEL
      MAXV=MAXVRT
      MAXTB=MAXTAB
      MAXCP=MAXNCP
      MAXBU=MAXNBU
      MAXRU=MAXREG
      MXPST=MAXPST
C
C RECORD LENGTH FOR DIFFERENT MACHINES
C
C*VAX  LREC=2048
C*IRIS LREC=2048
C*TITA LREC=2048
C*APOL LREC=8192
C*IBM  LREC=8192
C*HP   LREC=8192
C*SUN  LREC=8192
C*CRAY LREC=16384
C*FPS  LREC=16384
c      LREC=2048
c ** EDIT THIS LINE TO REFLECT YOUR TARGET MACHINE **
       LREC=8192
c **
C DEFAULTS
      LR=5
      LW=6
      LPOST=0
      IERROR=0
      FMTOUT=.FALSE.
      WELEM=.FALSE.
C
C VERSION
C
C     IVERS=2300
C     new version: 3000 (HJ)
      IVERS=3000
      RVERS=FLOAT(IVERS)/1000.
c
      readStar_f = 1
c
C
C GET CASENAME
C
      OFILE='star'
      LCASE=70
      NCASE=70
c
      istat = OMFget_name_str_val(obj_id,
     .                            OMFstr_to_name('case'),
     .                            CASE,
     .                            NCASE)
c
      CALL STRTRM(CASE,CASE,LCASE)
      IF (LCASE.GT.NCASE) LCASE=NCASE
      IF (LCASE.EQ.0) THEN
        CASE='star'
        LCASE=4
      ENDIF
C
C RESUME PREPROCESSING INFORMATION FROM FILE 16
C
      CALL RESUME(16,IERROR,NCPDIM,NCYDIM,ISCYC,ICOUP)
      IF (IERROR.EQ.1) THEN
         readStar_f = 0
         return
      ENDIF
c
      istat = OMFfind_subobj(obj_id,
     .                       OMFstr_to_name('out_fld'),
     .                       OM_OBJ_RD,
     .                       tmp_id)
c
      istat = OMFget_obj_val(tmp_id,fld_id)
C
C DECIDE LOADING WHICH POST DATA
C
      LPOST = 9
c
      ltype = 0
      if (optset(obj_id,'load_type',ltype)) return
      if (ltype .eq. 1) then
         LPOST = 9
      else if (ltype .eq. 2) then
         LPOST = 29
      endif
c
C
C LOAD POST DATA FROM FILE 9 OR 29
C
      IF (LPOST.EQ.9) THEN
        CALL LOAD9(LREC,IERROR)
      ELSEIF (LPOST.EQ.29) THEN
chj
        istat = OMFget_name_int_val(obj_id,
     .                              OMFstr_to_name('trtype'),
     .                              itoggv)
        trtype = 'F'
        if (itoggv .eq. 1) trtype = 'L'
        if (itoggv .eq. 2) trtype = 'S'
        if (itoggv .eq. 3) trtype = 'I'
chj
chj
        istat = OMFget_name_int_val(obj_id,
     .                              OMFstr_to_name('trstep'),
     .                              trstep)
chj
chj
        istat = OMFget_name_real8_val(obj_id,
     .                              OMFstr_to_name('trtime'),
     .                              trtime)
chj
        CALL TRLOAD(LREC,IERROR,trtype,trstep,trtime)
chj
      ENDIF
      IF (IERROR.EQ.1) THEN
         readStar_f = 0
         return
      ENDIF
c
      scale8 = scale9
      call co2fld(fld_id,ndoffs)
      call ce2fld(fld_id,ndoffs)
c
C
      IF (NCELL+NBC.GT.MAXCEL) THEN
        WRITE(LW,1014)NCELL
1014    FORMAT(/,' **THIS PROGRAM IS NOT DIMENSIONED LARGE ENOUGH.',/,
     1           '   SET PARAMETERS MAXCEL > ',I7,' AND RECOMPILE.')
        readStar_f = 0
        return
      ENDIF
      IF (NBC.GT.MAXBND) THEN
        WRITE(LW,1016)NBC
1016    FORMAT(/,' **THIS PROGRAM IS NOT DIMENSIONED LARGE ENOUGH.',/,
     1          '   SET PARAMETER MAXBND > ',I7,' AND RECOMPILE.')
        readStar_f = 0
        return
      ENDIF
C
C DECIDE ELEMENT CONVERSION
C
      WELEM = .FALSE.
c
      lcd = 0
      if (optset(obj_id,'cdconv',lcd)) goto 570
      if (lcd .gt. 0) WELEM = .TRUE.
c
C
C CELL DATA (14 OF THEM) IS STORED IN THE ARRAY VECTOR IN ORDER:
C   U, V, W, PRESSURE, TURBULENT ENERGY, DISSIP, VISCOSITY, TEMP,
C   DENSITY, LAM VISCOSITY, SPEC HEAT, CONDUCTIVITY, CONCENTRATION
C
      if (lcd .eq. 1) then
         ITEM = 'SCAL'
      else if (lcd .eq. 2) then
         ITEM = 'FLUX'
      endif
c
C
      IF (WELEM) THEN
c
        istat = OMFget_name_int_val(obj_id,
     .                              OMFstr_to_name('pconv'),
     .                              itoggv)
        pans = 'R'
        if (itoggv .eq. 1) pans = 'A'
c
        istat = OMFget_name_int_val(obj_id,
     .                              OMFstr_to_name('tconv'),
     .                              itoggv)
        tans = 'R'
        if (itoggv .eq. 1) tans = 'A'
c
        CALL CELGET(ITEM,NCPDIM,ICOUP,pans,tans)
C ELEMENT/CELL  CONVERSION PORTION
        call fldelm(obj_id,fld_id)
      ENDIF
C
C PROMPT FOR WALL CONVERSION
C
C SKIP IF NO WALL DATA
570   IF (NDATA(1,3).EQ.0) GO TO 700
C
      WWALL = .FALSE.
c
      lwd = 1
      if (optset(obj_id,'wdconv',lwd)) WWALL = .TRUE.
c
C
C WALL DATA (14 OF THEM) IS STORED IN THE ARRAY VECTOR IN SUCH ORDER:
C   SFX, SFY, SFZ, YPLUS, DIST, TEMP, HEAT TRANSFER,
C   MASS TRANSFER, HEAT FLUX, MASS FLUX, THERMAL RADISTION,
C   THERMAL INCIDENT RADIOSITY, SOLAR RADIATION,
C   SOLAR INCIDENT RADIOSITY
C
      IF (WWALL) THEN
        CALL SRFGET(IERROR,DUM2(2048+MAXCEL+1),ICOUP)
        IF (IERROR.EQ.1) THEN
           readStar_f = 0
           return
        ENDIF
C WALL CONVERSION
cfix        CALL PATWAL(FMTOUT)
      ENDIF
 700  CONTINUE
C
      readStar_f = 1
      return
      end

      logical function optset(obj_id,obj_name,id)
c#include "avs/omf.inc"
      include "avs/omf.inc"
      integer obj_id(OIDSIZ)
      character*(*) obj_name
c
      optset = .false.
c
      istat = OMFget_name_int_val(obj_id,
     .                            OMFstr_to_name(obj_name),
     .                            ival)
      if (istat .ne. 1) return
c
      if (ival .eq. id) optset = .true.
      id = ival
c
      return
      end

      logical function lstset(obj_id,obj_name,id)
c#include "avs/omf.inc"
      include "avs/omf.inc"
      integer obj_id(OIDSIZ)
      character*(*) obj_name
      integer ibase(1)
c
      iptr = OMFret_name_array_ptr(obj_id,
     .                             OMFstr_to_name(obj_name),
     .                             OM_GET_ARRAY_RD,
     .                             isize,
     .                             itype)
      ioffs = ARRFoffset(iptr,ibase,DTYPE_INT)
c
      lstset = .true.
      do 10 i=1,isize
      if (ibase(ioffs+i) .eq. id) return
 10   continue
c
      lstset = .false.
c
      return
      end

      subroutine co2fld(fld_id,ndoffs)
c#include "avs/omf.inc"
      include "avs/omf.inc"
      integer fld_id(OIDSIZ), ndoffs(1), tmp_id(OIDSIZ)
      real rbase(1)
      COMMON/NODES/C(3,1)
      COMMON/KEY/MAXN,MAXE,ICSYS,MAXSYS,ITYPE,PFIRST,IVERS,NUMW,
     1           NI,NJ,NK,NF,MAXB,IBFILL,NOVICE,KEYS(10),LW,LR,
     2           LECHO,LNUT,MXTB,LTURBI,LTURBP,SETADD,NSENS,NPART,
     4           SCALE8,KEYS2(18)
C
      NC=0
      DO 100 N=1,MAXN
        IF (C(1,N).GT.1.E29) GO TO 100
        NC=NC+1
        ndoffs(n) = n - nc
100   CONTINUE
      istat = OMFset_name_int_val(fld_id,
     .                            OMFstr_to_name('nnodes'),
     .                            NC)
      istat = OMFset_name_int_val(fld_id,
     .                            OMFstr_to_name('nspace'),
     .                            3)
c
      istat = OMFfind_subobj(fld_id,
     .                       OMFstr_to_name('coordinates'),
     .                       OM_OBJ_RW,
     .                       tmp_id)
c
      iptr = OMFret_name_array_ptr(tmp_id,
     .                             OMFstr_to_name('values'),
     .                             OM_GET_ARRAY_WR,
     .                             isize,
     .                             itype)
      ioffs = ARRFoffset(iptr,rbase,DTYPE_FLOAT)
c
      NC=0
      DO 200 N=1,MAXN
        IF (C(1,N).GT.1.E29) GO TO 200
        i = ioffs + nc*3
        rbase(i+1) = scale8 * c(1,n)
        rbase(i+2) = scale8 * c(2,n)
        rbase(i+3) = scale8 * c(3,n)
        NC=NC+1
200   CONTINUE
c
      call ARRFfree(iptr)
c
      return
      end

      subroutine ce2fld(fld_id,ndoffs)
c#include "avs/omf.inc"
      include "avs/omf.inc"
      integer fld_id(OIDSIZ), ndoffs(1)
      integer tmp_id(OIDSIZ), set_id(OIDSIZ)
      integer ibase(1)
      COMMON/CELLS/NE(9,1)
      COMMON/CTABLE/ICTAB(10,1)
      COMMON/NTABLE/CTNAME(1)
      COMMON/ARSIZE/MAXC,MAXV,MAXCP,MAXTB,MAXBU,MAXRU,MXPST
      COMMON/KEY/MAXN,MAXE,ICSYS,MAXSYS,ITYPE,PFIRST,IVERS,NUMW,
     1           NI,NJ,NK,NF,MAXB,IBFILL,NOVICE,KEYS(10),LW,LR,
     2           LECHO,LNUT,MXTB,LTURBI,LTURBP,SETADD,NSENS,NPART,
     4           SCALE8,KEYS2(18)
      character*4 ctname, dname*15
c
      istat = OMFfind_subobj(fld_id,
     .                       OMFstr_to_name('cell_set'),
     .                       OM_OBJ_RD,
     .                       set_id)
c
      iset = 0
      do 200 m=1,maxtb
      if (ictab(1,m) .le. 0) goto 200
      if (ictab(1,m) .gt. 2) goto 200
c
      nc = 0
      do 210 n=1,maxe
      if (ne(1,n) .lt. 1) goto 210
      if (ne(9,n) .ne. m) goto 210
      nc = nc + 1
 210  continue
      if (nc .eq. 0) goto 200
c
      nsets = iset + 1
      istat = OMFset_name_int_val(fld_id,
     .                            OMFstr_to_name('ncell_sets'),
     .                            nsets)
c
      istat = OMFget_array_val(set_id,iset,tmp_id,OM_OBJ_RW)
      iset = iset + 1
c
      istat = OMFset_name_int_val(tmp_id,
     .                            OMFstr_to_name('ncells'),
     .                            nc)
      istat = OMFset_name_int_val(tmp_id,
     .                            OMFstr_to_name('cell_ndim'),
     .                            3)
      istat = OMFset_name_int_val(tmp_id,
     .                            OMFstr_to_name('cell_order'),
     .                            1)
      istat = OMFset_name_int_val(tmp_id,
     .                            OMFstr_to_name('cell_nnodes'),
     .                            8)
      istat = OMFset_name_int_val(tmp_id,
     .                            OMFstr_to_name('poly_flag'),
     .                            0)
c
      dname(12:15) = ctname(m)
      if (dname(12:15) .eq. '    ') then
         dname(12:12) = '#'
         write(dname(13:15),'(i3)') m
         if (ictab(1,m) .eq. 1) dname(1:11) = 'Fluid      '
         if (ictab(1,m) .eq. 2) dname(1:11) = 'Solid      '
         if (ictab(1,m) .eq. 3) dname(1:11) = 'Baffle     '
         if (ictab(1,m) .eq. 4) dname(1:11) = 'Shell      '
         if (ictab(1,m) .eq. 5) dname(1:11) = 'Line       '
         if (ictab(1,m) .eq. 6) dname(1:11) = 'Point      '
      endif
      istat = OMFset_name_str_val(tmp_id,
     .                            OMFstr_to_name('name'),
     .                            dname)
c
      iptr = OMFret_name_array_ptr(tmp_id,
     .                             OMFstr_to_name('node_connect_list'),
     .                             OM_GET_ARRAY_WR,
     .                             isize,
     .                             itype)
      ioffs = ARRFoffset(iptr,ibase,DTYPE_INT)
c
      nc = 0
      do 220 n=1,maxe
      if (ne(1,n) .lt. 1) goto 220
      if (ne(9,n) .ne. m) goto 220
      do 221 k=1,8
      kk = ioffs + nc*8 + k
      ibase(kk) = ne(k,n) - ndoffs(ne(k,n)) - 1
 221  continue
      nc = nc + 1
 220  continue
c
      call ARRFfree(iptr)
c
 200  continue
c
      return
      end

      subroutine fldelm(obj_id,fld_id)
c#include "avs/omf.inc"
      include "avs/omf.inc"
      integer obj_id(OIDSIZ), fld_id(OIDSIZ), set_id(OIDSIZ)
      integer tmp_id(OIDSIZ), val_id(OIDSIZ), cda_id(OIDSIZ)
C
C CONVERT TO ELEMENT DATA
C
      COMMON/CELLS/NE(9,1)
      COMMON/CTABLE/ICTAB(10,1)
      COMMON/NTABLE/CTNAME(1)
      COMMON/ARSIZE/MAXC,MAXV,MAXCP,MAXTB,MAXBU,MAXRU,MXPST
      COMMON/KEY/MAXN,MAXE,ICSYS,MAXSYS,ITYPE,PFIRST,IVERS,NUMW,
     1           NI,NJ,NK,NF,MAXB,IBFILL,NOVICE,KEYS(10),LW,LR,
     2           LECHO,LNUT,MXTB,LTURBI,LTURBP,SETADD,NSENS,NPART,
     4           SCALE8,KEYS2(18)
      COMMON/PDATA/VECTOR(14,1)
      COMMON/CASEN/CASE,TITLE
      COMMON/POSTD/ITERU,TIMEU,ITERS,TIMES,VMING,VMAXG,VMINL,VMAXL,
     1             SMING,SMAXG,SMINL,SMAXL,NDATA(200,3),LPOST,
     2             NCELL,NBC,NBW,NBS,NBB,NNODE,WPOST,LDCELL,LDVERT,
     3             LSORT,LUNMOD,IPSYS,LOPER,LRSKIP,TREF,LDSURF,
     4             ISRTAB,ICSH1,NSITEM,LSRF(200),NBCUT,NBCYC,PREF1,
     5             PREPP(2,99),NTCELL,LCNPST,LDPPRS,
     6             LPCORD,NUMCON,NSC,TREFM(99),LVERS,LDFLUX,
     7             IREFRM,IRESYS,OMEREF,ADDREL,PGRAV(7,99),PSPIN(7,99),
     8             PMW(99),PMWS(50,99),SCALE9,LPTYP,LADJST,LPINTP,TIMEP,
     9             ITERP,LRELA,LMVGR,NDATAP(200,3),IRETW,NWSET,SPCYC,
     *             LSTAR(100),NBNCST,NBNCEN,NBSI,NSCL,NREG,
     1             MRECMM,NBP23,NCLPS,NWPRSM,NPRSM,NCLP,NCLPF,ITYPEN
      DIMENSION ISUB(80)
      CHARACTER CASE*70,FNAME*80,TITLE*52,SUB1*50,SUB2*50
      CHARACTER CITER*6
      DIMENSION DTYPE(15)
      CHARACTER DTYPE*4
      DATA DTYPE/'FLUX',' U  ',' V  ',' W  ',' P  ',' TE ',' ED ',
     1           'VIS ',' T  ','DENS','LAMV',' CP ','COND','ENTH',
     2           'CONC'/
c
      integer ibase(1)
      real rbase(1)
c
      jptr = OMFret_name_array_ptr(obj_id,
     .                             OMFstr_to_name('cdsel'),
     .                             OM_GET_ARRAY_RD,
     .                             jsize,
     .                             jtype)
      joffs = ARRFoffset(jptr,ibase,DTYPE_INT)
c
      istat = OMFget_name_int_val(fld_id,
     .                            OMFstr_to_name('ncell_sets'),
     .                            ncsets)
      istat = OMFfind_subobj(fld_id,
     .                       OMFstr_to_name('cell_set'),
     .                       OM_OBJ_RD,
     .                       set_id)
c
      do 100 n=1,ncsets
      istat = OMFget_array_val(set_id,n-1,val_id,OM_OBJ_RW)
      istat = OMFset_name_int_val(val_id,
     .                            OMFstr_to_name('ncell_data'),
     .                            jsize)
C
      istat = OMFfind_subobj(val_id,
     .                       OMFstr_to_name('cell_data'),
     .                       OM_OBJ_RD,
     .                       cda_id)
      do 100 jt=1,jsize
      istat = OMFget_array_val(cda_id,jt-1,tmp_id,OM_OBJ_RW)
      istat = OMFset_name_int_val(tmp_id,
     .                            OMFstr_to_name('veclen'),
     .                            1)
 100  continue
      print*,'Cell Data initialized'
c
      iset = 0
      do 200 m=1,maxtb
      if (ictab(1,m) .le. 0) goto 200
      if (ictab(1,m) .gt. 2) goto 200
      istat = OMFget_array_val(set_id,iset,val_id,OM_OBJ_RW)
      istat = OMFget_name_int_val(val_id,
     .                            OMFstr_to_name('ncells'),
     .                            ncells)
      istat = OMFfind_subobj(val_id,
     .                       OMFstr_to_name('cell_data'),
     .                       OM_OBJ_RD,
     .                       cda_id)
c
      do 210 jt=1,jsize
      j = ibase(jt+joffs) + 1
      istat = OMFget_array_val(cda_id,jt-1,tmp_id,OM_OBJ_RW)
c
      istat = OMFset_name_str_val(tmp_id,
     .                            OMFstr_to_name('labels'),
     .                            dtype(j+1))
c
      iptr = OMFret_name_array_ptr(tmp_id,
     .                             OMFstr_to_name('values'),
     .                             OM_GET_ARRAY_RW,
     .                             isize,
     .                             itype)
      ioffs = ARRFoffset(iptr,rbase,DTYPE_FLOAT)
c
      nc = 0
      do 210 n=1,maxe
      if (ne(1,n) .lt. 1) goto 210
      if (ne(9,n) .ne. m) goto 210
      kk = ioffs + nc + 1
      rbase(kk) = vector(j,n)
      nc = nc + 1
 210  continue
      if (nc .eq. 0) goto 200
      iset = iset + 1
 200  continue
c
      return
      end


c     ****************************************************************
c     *                                                              *
c     *                      subroutine chkcrack                     *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 12/6/20 rhd                *
c     *                                                              *
c     *        This routine drives the check on conditions to tell   *
c     *        if crack growth will occur.  This calls routines for  *
c     *        both crack growth and discrete crack growth.          *
c     *                                                              *
c     ****************************************************************
c
c
c
      subroutine chkcrack( step, iter )
c
      use global_data, only : out
      use damage_data, only : crack_growth_type
c
      implicit none
c
      integer :: step, iter
      logical :: debug
c
      debug = .false.
c
      if ( debug ) write(out,*) '>>> enter chkcrack <<<'
c
c              Return if no crack growth specified.
c
c              crack_growth_type:
c
c                 (1)  element extinction by critical porosity
c                      in Gurson-Tvergaard material model
c                      or the extended Gurson-Tvergaard model
c                 (2)  node release on attainment of critical
c                      ctoa
c                 (3)  element extinction by stress-modified
c                      critical strain criterion. any material
c                      model.
c                 (4)  crack growth using cohesive elements
c                 (5)  user requested by input command. element list
c                      provided in module damage_data
c
c              Lower level routines are separated into other .f files by
c              the type of crack growth.
c
c
      select case( crack_growth_type )
      case(0)
         if(debug) write (out,*) '>>>> no crack growth specified.'
      case(1)
         if(debug) write (out,*) '>>>> use gurson crack growth.'
         call chk_elem_kill( debug, step, iter )
      case(2)
         if(debug) write (out,*) '>>>> use node release crack growth.'
         call chk_node_release( debug, step, iter )
      case(3)
         if(debug) write (out,*) '>>>> use smcs crack growth.'
         call chk_elem_kill( debug, step, iter )
      case(4)    !  cohesive
         call chk_elem_kill( debug, step, iter )
         return
      case(5)
         if(debug) write (out,*) '>>>> user specified kill element.'
         call chk_elem_kill( debug, step, iter )
      end select
c
      if( debug ) then
         call dam_debug
         write(out,*) '>>>>>>>> leaving chkcrack <<<<<<<'
      end if
c
      return
      end

c     ****************************************************************
c     *                                                              *
c     *                      subroutine chk_elem_kill                *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 12/12/2020 rhd             *
c     *                                                              *
c     *        checks conditions to see if crack                     *
c     *        growth will occur by element extinction               *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine chk_elem_kill( debug, step, iter )
c
      use global_data, only : out, noelem, current_load_time_step,
     &                        iprops, props, nelblk, elblks
      use dam_param_code, only : dam_param, growth_set_dbar
      use elem_extinct_data, only : dam_blk_killed, dam_state,
     &                              kill_order_list, dam_print_list
      use main_data, only : output_packets, packet_file_no
      use damage_data, only : no_killed_elems, dam_ptr, max_dam_state,
     &                        crack_growth_type, num_user_kill_elems,
     &                        release_type, user_kill_list_now,
     &                        all_elems_killed, killed_element_limit,
     &                        num_elements_killed, kill_order,
     &                        smcs_list_file_flag, smcs_list_file_name,
     &                        num_kill_order_list,
     &                        stop_killed_elist_length,
     &                        deleted_elist_to_stop
c
      implicit none
c
      integer, intent(in) :: step, iter
      logical, intent(in) :: debug
c
c               local declarations
c
      integer, parameter :: max_local_list=500 ! max elements that
c                                                can be killed this call
c
      integer :: local_packet(max_local_list), elem, elem_ptr,
     &           local_count, blk, chk_kill, cohes_type, count,
     &           element, felem, i, span
      integer, parameter :: local_pkt_type(5) = (/ 20, 0, 21, 10, 0 / )
      logical :: blk_killed, killed_this_time, killed_found,
     &           kill_the_elem, elems_left, ldummy1, ldummy2,
     &           local_debug, stop_solution
      logical, external :: scan_entry_in_list
      double precision ::
     &   porosity, eps_plas, eps_crit,
     &   values(20), local_status(max_local_list,3), orig_poros,
     &   ext_shape, ext_spacing, avg_triaxiality, avg_zeta,
     &   avg_bar_theta
      logical :: fgm_cohes, ext_gurson, option_exponential,
     &           option_ppr, local_write_packets, do_kill_in_order,
     &           found_exponential, found_ppr, found_cavit,
     &           option_cavit
c
      local_debug = .false. ! debug
      if( local_debug ) then
         write(out,*) '... entered chk_elem_kill ...'
         write(out,*) '    ... no_killed_elems:',no_killed_elems
      end if
c
c              1) Loop for all elements. process killable elements.
c                 kill as required.
c
      killed_this_time  = .false.
      elems_left        = .false.
      local_count       = 0
      found_exponential = .false.
      found_ppr         = .false.
      found_cavit       = .false.
      stop_solution     = .false.
c
      do elem = 1, noelem
c
         elem_ptr = dam_ptr(elem)
         if( elem_ptr .eq. 0 ) cycle     ! element not killable
         if( local_debug ) write(out,*) 'killable element is:',elem
c
c                If element has been previously killed, update it's
c                unloading state vector, and then skip the rest of the
c                loop. we do this for traction-separation law as well
c                since other routines look at dam_state.
c
         if( dam_state(elem_ptr) .gt. 0 ) then ! element killed already
            if( dam_state(elem_ptr) .le. max_dam_state )
     &           dam_state(elem_ptr) = dam_state(elem_ptr) + 1
            cycle
         end if
c
c                 calculate damage parameter(s) for element,
c                 then check it. if exceeded, set-up data structures for
c                 internal force release using fixed no.
c                 of load steps or the traction-separation law.
c
         select case( crack_growth_type )
         case( 1 )  ! GTN
            call dam_param(
     &         elem=elem, kill_now=kill_the_elem, debug=debug,
     &         porosity=porosity, eps_plas=eps_plas, eps_crit=eps_crit,
     &         ext_gurson=ext_gurson, ext_shape=ext_shape,
     &         ext_spacing=ext_spacing )
         case( 3 )  ! SMCS
            call dam_param(
     &         elem=elem, kill_now=kill_the_elem, debug=debug,
     &         eps_plas=eps_plas, eps_crit=eps_crit,
     &         avg_triaxiality=avg_triaxiality, avg_zeta=avg_zeta,
     &         avg_bar_theta=avg_bar_theta )
         case( 4 )
            call dam_param_cohes( elem, kill_the_elem, debug,
     &                            values, 2 )
         case( 5 )
            kill_the_elem = .false.
            do i = 1, num_user_kill_elems
             if( elem  == user_kill_list_now(i) ) then
                 kill_the_elem = .true.
                 exit
             end if
            end do
         end select
c
         killed_this_time = killed_this_time .or. kill_the_elem
         if( .not. kill_the_elem ) then
           elems_left = .true. ! killable elements remain to be killed
           cycle
         end if
c
c                  kill now and make output packet data as needed.
c
         call output_kill_messages
         if( output_packets ) call chk_elem_kill_make_packets
c
c                 initialize global variables for 1st killed element
c                 null props and history for this newly killed element
c                 so subsequent stiffness will be zero. zero stresses,
c                 start the element force reduction process, constrain
c                 completely uncoupled nodes if required.
c
         if( no_killed_elems ) then
            call allocate_damage( 4 )
            if( release_type .eq. 2 ) call allocate_damage( 5 )
            call dam_init2( debug )
         end if
         num_elements_killed = num_elements_killed + 1
         call update_killed_energy( elem )
         call kill_element( elem, debug )
         call store_ifv( elem, elem_ptr, debug )
         call update_node_elecnt( elem, debug )
         if( release_type .eq. 2 ) call growth_set_dbar( elem,
     &             elem_ptr, debug, -1 )
c
c                 the user may have provided a list if elements.
c                 if this newly killed element is is the list,
c                 stop solution at cleanup in this routine.
c
         if( stop_killed_elist_length > 0 ) then
           if( scan_entry_in_list( elem, deleted_elist_to_stop,
     &         stop_killed_elist_length ) ) stop_solution = .true.
         end if

c
      end do  ! over all model elements
c
c
c         (2) packet output for newly killed elements at
c             for gurson, extended-gurson, smcs, cohesive
c
      local_write_packets = output_packets .and. local_count .gt. 0
      if( local_write_packets ) call chk_elem_kill_output_packets
c
c         (3) are elements left to be killed in model?
c
      if( .not. elems_left ) all_elems_killed = .true.
c

c         (4) if a killing order has been specified then make sure that
c             no element "holes" have been left.
c
      do_kill_in_order = kill_order .and. killed_this_time
      if( do_kill_in_order ) call chk_elem_kill_in_order
c

c         (5) check the element blocks to see if all elements in
c             them have been killed.  Set dam_blk_killed if so.
c
      if( killed_this_time ) call chk_elem_kill_chk_blk
c
c         (6) re-check for free nodes if any elements have ever
c             been killed. Just makes triple sure that there are
c             no free nodes.
c
      if( .not. no_killed_elems ) call chk_free_nodes( debug )
c
c         (7) if MPI, then all processors need to know what blocks
c             and elements have been killed.  Send dam_blk_killed
c             and dam_state.  Also have processors kill any elements
c             which they own which should be killed.
c             this is a dummy for non-MPI
c
      call wmpi_send_growth( killed_this_time )
c
c         (8) if limit on number of killed elements is exceeded,
c             stop the solution.
c
      if( num_elements_killed > killed_element_limit ) then
          write(out,9000) killed_element_limit
          call store( ' ','kill_limit_restart.db', ldummy1, ldummy2 )
          call warp3d_normal_stop
      end if
c
c         (9) the user may have provided a list of elements
c             to stop the analysis if <any> of them are killed
c             stop the solution.
      if( stop_solution ) then
          write(out,9010)
          call store( ' ','kill_limit_restart.db', ldummy1, ldummy2 )
          call warp3d_normal_stop
      end if
c
      return
c
 9000 format(/,1x,">>>>> Number of currently killed (deleted)",
     & " elements has reached the ",
     &       /,7x,"user-specified limit of: ",i6,".",
     &       /,7x,"Restart file: kill_limit_restart.db written.",
     &       /,7x,"Job ended normally."// )
 9010 format(/,1x,">>>>> An element just killed appears in the user",
     & " defined list to stop the solution.",
     &       /,7x,"Restart file: kill_limit_restart.db written.",
     &       /,7x,"Job ended normally."// )
c
c
      contains
c     ========
c
      subroutine output_kill_messages
      implicit none
c
      integer :: device
      logical :: fexists
c
c                 kill this element right now. record status for
c                 subsequent packet output if neeeded. write usual
c                 output about element death.
c
      local_count = local_count + 1
      select case( crack_growth_type )
      case( 1 )
          if( .not. ext_gurson ) write(out,9000) elem, porosity
          if( ext_gurson ) write(out,9002) elem, porosity,
     &                     ext_spacing, ext_shape
          return
      case( 3 )
          write(out,9010) elem, eps_plas, eps_crit, avg_triaxiality,
     &                    avg_zeta, avg_bar_theta
          if( .not. smcs_list_file_flag ) return ! delete elements file
          inquire( file=smcs_list_file_name, exist=fexists )
          open( newunit=device,file=smcs_list_file_name,
     &          form='formatted', status='unknown',
     &          access='sequential', position='append' )
          if( .not. fexists ) write(device,9018)
          write(device,9020) current_load_time_step,
     &                       elem, eps_plas, eps_crit,
     &                       avg_triaxiality, avg_zeta, avg_bar_theta
          close(unit=device)
        return
      case( 4 )
          cohes_type         = iprops(27,elem)
          option_exponential = cohes_type .eq. 4
          option_ppr         = cohes_type .eq. 6
          option_cavit       = cohes_type .eq. 7
          found_exponential  = found_exponential .or.
     &                         option_exponential
          found_ppr   = found_ppr .or. option_ppr
          found_cavit = found_cavit .or. option_cavit
          count = 0
          if( found_exponential ) count = count + 1
          if( found_ppr ) count = count + 1
          if( found_cavit ) count = count + 1
          if( count .gt. 1 ) then
            write(out,9400) elem
            call die_gracefully
          end if
          if( option_exponential )
     &       write(out,9200) elem, values(6)/values(7), values(8)
          if( option_ppr )   write(out,9220) elem
          if( option_cavit ) write(out,9230) elem
          return
      case( 5 )
          write(out,9240) elem
      end select
c
      return
c
 9000 format(/,'   >> element death invoked for element: ',i7,
     & '.   f: ',f6.3)
 9002 format(/,'   >> element death invoked for element: ',i7,
     & '.   f, W, X: ',3f8.3)
 9010 format(/,' >> element death option invoked before next step',
     &       /,'    element: ',i7,' is now killed.',
     &       /,'    plastic strain: ',f8.5,' is > limit of: ',f8.5,
     &       /,'    plastic strain weighted values: bar_T, ',
     &         'bar_xi, bar_theta:',f6.3,2x,f6.3,2x,f6.3)
 9018 format('!',/,'!  SMCS quantities when critical plastic ',
     & 'strain reached for elements', /,
     & '!   (element deletion begins at listed step number)',
     & /,'!',/,
     & 3x,'step     elem   ebarp  ebarp_crit bar_T  bar_xi   bar_theta')
 9020 format(2x,2i8,f8.5,1x,f8.5,1x,f6.3,2x,f6.3,2x,f6.3)
 9200 format(/,'   >> element death invoked for element: ',i7,
     & '.   Deff/Dpeak: ',f5.2,' Teff/Tpeak: ',f5.2)
 9220 format(/,'   >> element death invoked for element: ',i7,
     & '.  PPR cohesive option')
 9230 format(/,'   >> element death invoked for element: ',i7,
     & '.  cavit cohesive option')
 9240 format(/,'   >> element death invoked for element: ',i7,
     & '.  user-directed removal')
 9400 format(/,'FATAL ERROR: mixed cohesive options not allowed',
     & /,      '             at present in WARP3D with crack growth.'
     & /,      '             found while processing element: ',i7,
     & /,      '             job aborted.' )
c
      end subroutine output_kill_messages
c
      subroutine chk_elem_kill_output_packets
      implicit none
c
      write(packet_file_no) local_pkt_type(crack_growth_type),
     &                      local_count, step, iter
      do elem = 1, local_count
        element = local_packet(elem)
        select case( crack_growth_type )
        case( 1 )
          orig_poros = props(26,element)
          write(packet_file_no) element,orig_poros,
     &                  local_status(elem,1),
     &                  local_status(elem,2),local_status(elem,3)
        case( 3 )
          write(packet_file_no) element, local_status(elem,1),
     &                                  local_status(elem,2)
        case( 4 )
          write(packet_file_no) element, local_status(elem,1),
     &          local_status(elem,2), int(local_status(elem,3))
        end select
      end do
c
      return
      end subroutine chk_elem_kill_output_packets
c
      subroutine chk_elem_kill_in_order
      implicit none
c
      if ( debug ) write (out,*) '>>> checking for holes....'
      killed_found = .false.
      do chk_kill = num_kill_order_list,1, -1
        elem     = kill_order_list(chk_kill)
        elem_ptr = dam_ptr(elem)
        if( .not. killed_found ) then
          if( dam_state(elem_ptr) .ne. 0 ) killed_found = .true.
        else
          if( dam_state(elem_ptr) .eq. 0 ) then
             write (out,9100) elem
             num_elements_killed = num_elements_killed + 1
             call update_killed_energy( elem )
             call kill_element( elem, debug )
             call store_ifv( elem, elem_ptr, debug )
             call update_node_elecnt( elem, debug )
             if ( release_type .eq. 2 )
     &          call growth_set_dbar( elem, elem_ptr,
     &               debug, -1 )
          end if
        end if
      end do  ! chk_kill
c
      return
c
 9100 format(/,' >> element death option invoked before next step',
     &       /,'    element: ',i7,' is now killed to make crack',
     &       /,'    face uniform.')
c
      end subroutine   chk_elem_kill_in_order
c
      subroutine chk_elem_kill_make_packets
      implicit none
c
      if( local_count .gt. max_local_list ) then
         write(out,9300)
         call die_gracefully
      end if
      select case( crack_growth_type )
      case( 1 )
           local_packet(local_count) = elem
           local_status(local_count,1) = porosity
           local_status(local_count,2) = ext_spacing
           local_status(local_count,3) = ext_shape
      case( 3 )
           local_packet(local_count) = elem
           local_status(local_count,1) = eps_plas
           local_status(local_count,2) = eps_crit
      case( 4 )
           if( option_exponential ) then
             local_packet(local_count) = elem
             local_status(local_count,1) = values(6)/values(7)
             local_status(local_count,2) = values(8)
             local_status(local_count,3) = 4.0
           end if
           if( option_ppr ) then
             local_packet(local_count) = elem
             local_status(local_count,1) = values(5)
             local_status(local_count,2) = values(6)
             local_status(local_count,3) = 6.0
           end if
           if( option_cavit) then
             write(out,*) ' cavit death packets not implemented'
             call die_abort
           end if
      end select
c
      return
c
 9300 format(/,'FATAL ERROR: list length exceeded in chk_elem_kill',
     & /,      '             job aborted.' )
c
      end subroutine chk_elem_kill_make_packets
c
      subroutine chk_elem_kill_chk_blk
      implicit none
c
      do blk = 1, nelblk
        if( dam_blk_killed(blk) ) cycle
        span  = elblks(0,blk)
        felem = elblks(1,blk)
        if( iand( iprops(30,felem), 2 ) .eq. 0 ) cycle
        blk_killed = .true.
        do i = 1, span
         if( dam_state(dam_ptr(felem+i-1)) .eq. 0 ) blk_killed =.false.
        end do
        if( blk_killed ) dam_blk_killed(blk) = .true.
      end do
c
      return
      end subroutine chk_elem_kill_chk_blk
c
      end subroutine chk_elem_kill

c     ****************************************************************
c     *                                                              *
c     *                      subroutine dam_init2                    *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 12/6/20 rhd                *
c     *                                                              *
c     *        This routine is called when damage to an element      *
c     *        has occurred.  It initializes arrays to support       *
c     *        releasing of the internal forces present on element   *
c     *        at extinction.                                        *
c     *                                                              *
c     ****************************************************************
c
c
c
      subroutine dam_init2( debug )
c
      use global_data, only : out, nonode, noelem, iprops, c
c
      use elem_extinct_data, only : dam_node_elecnt, dam_face_nodes
      use main_data, only : incmap, incid, elems_to_blocks,
     &                      inverse_incidences
      use elem_block_data, only : cdest_blocks
      use damage_data, only : no_killed_elems, release_type, dam_ptr,
     &                        crk_pln_normal_idx, crack_plane_coord,
     &                        gurson_cell_size
c
      implicit none
c
      logical, intent(in) :: debug
c
      integer :: i, elem, elem_ptr, incptr, num_enodes, k1, k2,
     &           face_count, blk, rel_elem, enode, snode
      logical, parameter :: local_debug = .false.
      double precision :: node_coord(3), coord
      double precision, parameter :: plane_tol = 0.01d0
      integer, dimension(:,:), pointer :: cdest
c
      if( debug ) write(out,*) '>>>> in dam_init2'
c
      no_killed_elems = .false.
      do i = 1, nonode
         dam_node_elecnt(i) = inverse_incidences(i)%element_count
      end do
      if( debug ) then
         do i = 1, nonode
            write(out,9030) i, dam_node_elecnt(i)
         end do
      end if
c
c               set up the force release by traction-displacement
c               separation law if that option is being used.
c               for each killable element on the crack plane,
c               find the 4 nodes on the face opposite the crack
c               plane face used to define the element deformation.
c               we examine only the first 8 nodes of the element
c               (corner nodes).
c
      if( release_type .ne. 2 ) then
        if( debug ) write(out,*) '<<<< leaving dam_init2'
        return
      end if
c
      do elem  = 1, noelem
        elem_ptr = dam_ptr(elem)
        if( elem_ptr .eq. 0 ) cycle
        incptr     = incmap(elem)-1
        num_enodes = iprops(2,elem)
        k1         = num_enodes
        k2         = 2*num_enodes
        face_count = 0
        blk        = elems_to_blocks(elem,1)
        rel_elem   = elems_to_blocks(elem,2)
        cdest      => cdest_blocks(blk)%ptr
        do enode = 1, 8
          snode         = incid(incptr+enode)
          node_coord(1) = c( cdest(enode,rel_elem) )
          node_coord(2) = c( cdest(k1+enode,rel_elem) )
          node_coord(3) = c( cdest(k2+enode,rel_elem) )
          coord         = node_coord(crk_pln_normal_idx)
          if( abs(coord-crack_plane_coord) .le. plane_tol*
     &        gurson_cell_size ) cycle
          face_count = face_count + 1
          dam_face_nodes(face_count,elem_ptr) = snode
        end do   ! enode
        if( face_count .ne. 4 ) then
             write(out,*) 'FATAL error 1 in dam_init2'
             write(out,*) 'invalid plane definition for growth'
             write(out,*)  elem, elem_ptr, num_enodes,face_count
             call die_gracefully
             stop
        end if
      end do ! elem
c
      if( local_debug ) then
       write(out,*) '> element release type 2. face node table'
       do elem  = 1, noelem
        elem_ptr = dam_ptr(elem)
        if( elem_ptr .eq. 0 ) cycle
        write(out,9050) elem, dam_face_nodes(1,elem_ptr),
     &       dam_face_nodes(2,elem_ptr), dam_face_nodes(3,elem_ptr),
     &       dam_face_nodes(4,elem_ptr)
       end do
      end if
c
      if( debug ) write(out,*) '<<<< leaving dam_init2'
      return
 9030 format(' dam_node_elecnt(',i4,')=',i2)
 9050 format(' elem: ',i7, '  face nodes: ',8i8)
      end
c     ****************************************************************
c     *                                                              *
c     *                      subroutine chk_free_nodes               *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 12/6/20 rhd                *
c     *                                                              *
c     *        check each node in the structure to                   *
c     *        see if they are no longer connected to any element.   *
c     *        if so, it constrains them.                            *
c     *                                                              *
c     ****************************************************************
c
      subroutine chk_free_nodes( debug )
      use global_data ! old common.main
c
      use elem_extinct_data, only : dam_node_elecnt
      use main_data,         only : cnstrn, cnstrn_in
      use damage_data, only : csttail
c
      implicit none
c
      logical, intent(in) :: debug
c
      integer :: node, num_dof, j, glbal_dof
      double precision, parameter :: zero = 0.0d0
c
      if( debug ) write(out,*) '>>> in chk_free_nodes <<<'
c
c              Loop over each node -- if a node is now attatched to
c              no elements, constrain it.
c              Note: this could be more efficient -- we are looping
c                over all the nodes each time, and we could just
c                constrain the newly zeroed nodes.  This, however,
c                will also take care of the problem of a user
c                putting in a new set of constraints.
c
      do node = 1, nonode
       if( dam_node_elecnt(node) .ne. 0 ) cycle
       if( debug ) then
         write(out,*) 'free node ',node
         write (out,9010) node,cnstrn(dstmap(node)),
     &          cnstrn(dstmap(node)+1),cnstrn(dstmap(node)+2)
       end if
       do j = 1, 3    ! num_dof
         glbal_dof            = dstmap(node) + j-1
         cnstrn(glbal_dof)    = zero
         cnstrn_in(glbal_dof) = zero
         if( cstmap(glbal_dof) .eq. 0 ) then
           cstmap(csttail) = glbal_dof
           csttail         = glbal_dof
         end if
       end do
       cstmap(csttail) = -1
      end do
c
      if ( debug ) write(out,*) '>>> in chk_free_nodes <<<'
      return
 9010 format('  old constraints for node ',i7,' :',3(1x,e14.6))
      end
c     ****************************************************************
c     *                                                              *
c     *                      subroutine dam_print                    *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 12/6/20 rhd                *
c     *                                                              *
c     *     print status of killable elements or released nodes at   *
c     *     the beginning of a load step.                            *
c     *     optional smcs states output for smcs model
c     *                                                              *
c     ****************************************************************
c
c
      subroutine dam_print( step, iter )
c
      use damage_data, only : crack_growth_type, print_status,
     &                        print_top_list, const_front, smcs_states
c
      implicit none
c
      integer, intent(in) :: step, iter
c
      logical :: doprint
c
c           check to make sure crack growth is on and some type of
c           output is requested
c
      select case( crack_growth_type )
      case(0)       ! no action
      case(1)
         doprint = print_status .or. print_top_list
         if( .not. doprint ) return
         call dam_print_elem1( step, iter )
      case(2)
         doprint = print_status .or. print_top_list
         if( .not. doprint ) return
         if( const_front ) then
           call dam_print_front( step, iter)
         else
           call dam_print_node( step, iter )
         end if
      case(3)
         doprint = print_status .or. print_top_list .or. smcs_states
         if( .not. doprint ) return
         call dam_print_elem3( step, iter )
      case(4)
         doprint = print_status .or. print_top_list
         if( .not. doprint ) return
         call dam_print_elem4( step, iter )
      end select
c
      return
      end
c     ****************************************************************
c     *                                                              *
c     *                      subroutine dam_debug                    *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 06/23/94                   *
c     *                                                              *
c     *     This routine prints out all of the crack growth          *
c     *     parameters.                                              *
c     *                                                              *
c     ****************************************************************
c

      subroutine dam_debug
      use global_data ! old common.main
      use elem_extinct_data
      use node_release_data
      use damage_data
c
      implicit integer (a-z)
      double precision
     &     zero
      data zero / 0.0 /

c
      write (out,*)
      write (out,*) '>>>>>>>> dumping all relevent crack growth info:'
      write (out,*)
      write (out,*) '> crack_growth_type:',crack_growth_type
c
c              -- Gurson crack growth
c
      if( crack_growth_type.eq.1 ) then
         write (out,*) '> max_dam_state:', max_dam_state
         write (out,*) '> num_kill_elem:', num_kill_elem
         write (out,*) '> dam_ptr:'
         do i=1, noelem
            write (out,'(" dam_ptr(",i4,")=",i4)') i,dam_ptr(i)
         end do
         write (out,*) '> dam_state:'
         do i = 1, num_kill_elem
            write (out,'("dam_state(",i3,")=",i3)')i,dam_state(i)
         end do
         write (out,*) '> dam_ifv:'
         do i=1, num_kill_elem
            write (out,*) 'ifv entries for ptr:',i
            write(out,9000) (dam_ifv(j,i), j=1, mxedof)
         end do
         write (out,'(" > porosity_limit:",e14.6)') porosity_limit
         write (out,*) '> dam_blk_killed:'
         do blk = 1, nelblk
            if( dam_blk_killed(blk) ) then
               write (out,'(" dam_blk_killed(",i3,") is true")') blk
            else
               write (out,'(" dam_blk_killed(",i3,") is false")') blk
            endif
         end do
         if( kill_order ) then
            write (out,*) '> kill_order_list:'
            do i = 1, num_kill_order_list
               write (out,'("  entry:",i7," elem:",i6)')i,
     &              kill_order_list(i)
            end do
         end if
         if( .not.no_killed_elems ) then
            write(out,*) '> elems had been killed'
            write(out,*) '> dam_node_elecnt:'
            do i = 1, nonode
               write (out,'(" dam_node_elecnt(",i5,")=",i3)')i,
     &              dam_node_elecnt(i)
            end do
            write (out,*) '> dam_dbar_elems(current height, fraction)'
            if( release_type .eq. 2 ) then
               do i = 1, num_kill_elem
                  write (out,'(e13.6,2x,e13.6)') dam_dbar_elems(1,i),
     &                 dam_dbar_elems(2,i)
               end do
            end if
         else
            write (out,*) '> no elems have been killed.'
         end if
c
c              -- Node release crack growth
c
      else if (crack_growth_type.eq.2) then
c
         write (out,*) '> Number of crack plane nodes:',
     &        num_crack_plane_nodes
         write (out,'(" > half of CTOA for release:",e13.6)')
     &        critical_angle
         write (out,*) '> entry, node, state, ifv:'
         do i=1,num_crack_plane_nodes
            write (out,'(2x,i7,i6,i6,3x,e13.6)')i,crack_plane_nodes(i),
     &           crkpln_nodes_state(i), crkpln_nodes_react(i)
         enddo
         write (out,*) '> global nodes => crack plane nodes'
         do i=1, nonode
            write (out,*) ' ',i,':',inv_crkpln_nodes(i)
         enddo
         write (out,*) '> crack front list:'
         call write_list
         write (out,*) '> neighbor_nodes:'
         do i=1, num_crack_plane_nodes
            write (out,*) ' ',i,':  for node:',crack_plane_nodes(i),
     &           ' # neighbors=', num_neighbors(i),' which are:'
            write (out,'(7x,12i5)') (neighbor_nodes(j,i),
     &           j=1,num_neighbors(i))
         enddo
c
         if (release_type .eq. 2) then
            write(out,'(" > charlen,rel.frac,rel.height:",3e13.6)')
     &           char_length, release_fraction, release_height
            write (out,*) '> node_release_frac:'
            do i = 1, num_crack_plane_nodes
               write (out,'(2x,i7,2x,e13.6)')i,node_release_frac(i)
            enddo
         endif
c
         if ( overshoot_control_crk_grth ) then
            write (out,*) '> overshoot control is on:'
            write (out,'("   -control load fact:",e13.6)')
     &           control_load_fact
            write (out,'("   -old load fact:",e13.6)') old_load_fact
            write (out,'("   -min load fact:",e13.6)') min_load_fact
            write (out,'("   -overshoot_limit:",e13.6)')
     &           overshoot_limit
            write (out,'("   -CTOA range:",e13.6)') CTOA_range
            if (overshoot_allocated) then
               write (out,*) '   -overshoot stuff is allocated'
               write (out,'("   -old angles:")')
               write (out,'("     entry  angles")')
               do i=1, num_crack_plane_nodes
                  write (out,'(6x,i4,1x,12e13.6)') i,
     &                 (old_angles_at_front(i,j),j=1,12)
               enddo
            else
               write (out,*) '   -overshoot stuff is not allocated'
            endif
         else
            write (out,*) '> no overshoot control'
         endif
c
         if ( load_size_control_crk_grth ) then
            write (out,*) '> load size control is on'
            write (out,'("   -perm load fact:",e13.6)') perm_load_fact
            write (out,'("   -min steps:",i3)') min_steps_for_release
         else
            write (out,*) '> no load size control'
         endif
c
      if (const_front) then
       write (out,*) '> const front is set.'
       write (out,*) '  -master nodes:'
       do i=1, num_crack_fronts
         write (out,'(5x,i7)') master_nodes(i)
       enddo
       write (out,*) '  -crack_front_list:'
       do i=1, num_crack_fronts * num_nodes_grwinc
        write (out,'(5x,i3,":",40i7)') i,
     &             (crack_front_list(i,j),j=1,num_nodes_thick)
       enddo
c
       write (out,*) '> measured CTOA'
       write (out,'("   -init_ctoa_dist:",e13.6)') init_ctoa_dist
       write (out,'("   -ctoa_dist:",e13.6)') ctoa_dist
       write (out,*) '  -num_nodes_back =',num_nodes_back
       write (out,*) '  -master list (first 20 nodes):'
       do i=1, num_crack_fronts
         write (out,'(5x,i7,":",20i6)') i, (master_lines(i,j),
     &              j = 1, 20)
       enddo
      endif
c
         write (out,*)
c
c              -- No crack growth
c
      else if (crack_growth_type.eq.0) then
         write (out,*) '> no crack growth specified'
c
c              -- Error
c
      else
         write (out,*) ' Incorrect crack_growth_type:',
     &        crack_growth_type
      endif
c
      write (out,*)
      write (out,*) '<<<<<<<< finished dumping crack growth info.'
      write (out,*)
 9999 return
c
 9000 format(5(3x,4e14.6,/))
      end
c
c     ****************************************************************
c     *                                                              *
c     *                      function chk_killed                     *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 12/6/20 rhd                *
c     *                                                              *
c     *     given an element, returns true if the                    *
c     *     element had been killed, or false otherwise.             *
c     *                                                              *
c     ****************************************************************
c
      function chk_killed( elem ) result( t_chk_killed )
c
      use elem_extinct_data, only : dam_state
      use damage_data
c
      implicit none
c
      integer, intent(in) :: elem
      logical :: t_chk_killed
c
      integer :: elem_ptr
c
      t_chk_killed = .false.
      elem_ptr =  dam_ptr(elem)
      if( elem_ptr .ne. 0 ) then  ! element is killable
       if( dam_state( elem_ptr) .gt. 0 )
     &       t_chk_killed = .true.
      end if
c
      return
      end
c
c
c     ****************************************************************
c     *                                                              *
c     *                      function chk_killed_blk                 *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 12/6/2020 rhd              *
c     *                                                              *
c     *     for the specified block of elements, return a logical    *
c     *     vector indicating if each element is killed or active.   *
c     *     also a flag if the whole block is killed                 *
c     *                                                              *
c     ****************************************************************
c
      subroutine chk_killed_blk( block_no, status_vec, block_killed )
c
      use global_data, only : out, elblks, mxvl ! old common.main
c
      use elem_extinct_data, only : dam_state, dam_blk_killed
      use damage_data, only : growth_by_kill, dam_ptr
c
      implicit none
c
      integer, intent(in) :: block_no
      logical, intent(out) :: status_vec(mxvl), block_killed
c
      integer :: span, felem, i, n, nn, elem, elem_ptr
      logical, parameter :: check_consistency = .false.
c
      span  = elblks(0,block_no)
      felem = elblks(1,block_no) - 1
c
      block_killed = .false.
      status_vec   = .false.
      if( .not. growth_by_kill ) return
c
      if( .not. allocated(dam_blk_killed) ) then
        write(out,9100) 1
        call die_abort
      end if

      if( dam_blk_killed(block_no) ) then
        block_killed = .true.
        status_vec   = .true.
        return
      end if
c
      if( .not. allocated(dam_state) ) then
        write(out,9110) 2
        call die_abort
      end if
c
      if( check_consistency ) then
        n  = sizeof( dam_state )
        nn = sizeof( dam_ptr )
        do i = 1, span
          elem = felem + i
          if( elem > nn ) then
            write(out,9120) elem, nn
            call die_abort
          end if
          elem_ptr = dam_ptr( elem )
          if( elem_ptr .ne. 0 ) then
            if( elem_ptr > n .or. elem_ptr <=0 ) then
               write(out,9130) elem, n
               call die_abort
            end if
            if( dam_state(elem_ptr) .gt. 0 ) status_vec(i) = .true.
          end if
        end do
        return
      end if
c
      do i = 1, span  ! no consistency check
        elem = felem + i
        elem_ptr = dam_ptr( elem )
        if( elem_ptr .ne. 0 ) then
          if( dam_state(elem_ptr) .gt. 0 ) status_vec(i) = .true.
        end if
      end do
c
      return
c
 9100 format(/,'FATAL ERROR: chk_killed_nlk. Contact WARP3D group',
     &       /,'             Job terminated at ',i1,//)
 9110 format(/,'FATAL ERROR: chk_killed_nlk. Contact WARP3D group',
     &       /,'             Job terminated at ',i1,//)
 9120 format(/,'FATAL ERROR: chk_killed_nlk at 3. elem, nn:',2i8,
     &       /,'             Contact WARP3D group',
     &       /,'             Job terminated....'//)
 9130 format(/,'FATAL ERROR: chk_killed_nlk at 4. elem, n:',2i8,
     &       /,'             Contact WARP3D group',
     &       /,'             Job terminated....'//)
c
      end
c     ****************************************************************
c     *                                                              *
c     *                     subroutine damage_update                 *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 12/7/2020 rhd              *
c     *                                                              *
c     *        certain damage models need variables updated outside  *
c     *        element stress/history data (e.g. smcs )              *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine damage_update( now_step, now_iter )
c
      use global_data, only : out, noelem
      use elem_extinct_data, only : dam_state
      use damage_data, only :  crack_growth_type, dam_ptr
      use dam_param_code, only : dam_param_3_get_values
c
      implicit none
c
      integer :: now_step, now_iter
c
      integer :: elem, elem_ptr, dowhat
      logical :: debug, local_debug, process
      double precision :: d1, d2, d3, d4, d5, d6, d7, d8
c
      debug = .false.
      local_debug = .false. ! debug
      if( local_debug ) then
         write(out,*) '... entered damage_update ...'
      end if
c
c              only damage model using SMCS requires this update
c              using data outside the stress/history data.
c
c              the Gurson model, for example, only needs the instantaneous
c              values stored in the element stress/history data to
c              determine if element needs to be killed, a step
c              size reduction is needed, values for printing, etc.
c
      process = crack_growth_type .eq. 3
      if( .not. process ) return
c
c              Loop for all elements. process killable elements.
c
c$OMP PARALLEL DO PRIVATE( elem, elem_ptr, dowhat, d1, d2, d3, d4,
c$OMP&                     d5, d6, d7, d8 )
      do elem = 1, noelem
         elem_ptr = dam_ptr(elem)
         if( elem_ptr .eq. 0 ) cycle     ! element not killable
         if( dam_state(elem_ptr) .gt. 0 ) cycle ! element killed already
         if( local_debug ) write(out,*) 'killable element is:',elem
c
c                 calculate/update damage parameter(s) for element
c                 if this damage model requires it.
c
c                 only SMCS needs this now to support plastic strain
c                 weighted averages.
c
         select case( crack_growth_type )
         case( 3 ) !  SMCS
          dowhat = 4
          call dam_param_3_get_values( elem, debug, d1, d2, d3, d4,
     &                                 d5, d6, d7, d8, dowhat )
         end select
c
      end do  ! over all model elements
c$OMP END PARALLEL DO
c
      return
      end


        PARAMETER       ( MXMN = 8 )
        PARAMETER       ( MXLV = 220 )
        PARAMETER       ( NVAR = 17 )
        PARAMETER       ( NSTR = 4 )

        REAL*8          r8arr ( MXMN, MXLV ), r8arr2(MXMN, MXLV ),
     +                  r8arr3 ( MXMN, MXLV ), r8arr4(MXMN, MXLV )

        parameter(iu=9,iou=10)

        real pr,tt,td
        integer  xht,nlev,i, iargc, n,minu,k
        real  xpr,xu,xv
        real  temp,v,zx,d
        real  lat, lon
        real xt,xtd
        character*30 fin,fout
        character*10  date_tag,date
        character*6 dname
        character   argv*300,minute*2,M11*2,mins*2
        character*12 ilev
        character*12 M10,M1,M2,M3,M4,M5,M6
        real wlon,elon,slat,nlat

        CHARACTER       csubset*8, inf*200, outstg*200

        CHARACTER*80   ostr(NSTR)

        INTEGER        code,y,z,idate, iflag

c        ostr(1)='SAID GCLONG SCLF RPID'
        ostr(1)='SAID RPID'
        ostr(2)='SIDP SWCM YEAR MNTH DAYS'
        ostr(3)='HOUR MINU CLAT CLON'
        ostr(4)='TMDBST PRLC WDIR WSPD'

C*-----------------------------------------------------------------------
c*    Read the command-line arguments
c*
        n = iargc()
        IF (n .GE. 2) THEN
          call getarg( 1, argv )
          inf=argv
          call getarg(2,argv)
          date_tag=argv
          IF (n .eq. 6) THEN  ! User-specified lat/lon boundaries
            call getarg(3,argv)
            read(argv,*) wlon
            call getarg(4,argv)
            read(argv,*) elon
            call getarg(5,argv)
            read(argv,*) slat
            call getarg(6,argv)
            read(argv,*) nlat
            write(*,*) 'Lon/lat boundaries: ',wlon,elon,slat,nlat
          ELSE  ! Default lon/lat boundaries
            slat = -90.
            nlat = 90.
            wlon = -180.
            elon = 180.
          END IF
        ELSE
          write(*,*) 'Usage: decode_satwnd.x gdas.satwnd.t<HH>z.
     +<YYYYMMDD>.bufr <YYYYMMDDHH> west_lon east_lon
     +south_lat north_lat'
          STOP
        END IF

C*-----------------------------------------------------------------------

C*      Open the BUFR file
        OPEN (UNIT = 11, FILE=inf, form='unformatted')

        dname=' SATOB'
        fout= "Satob"//date_tag//'.obs'

C*      Open output file
        open(iou,file=fout,status='unknown',form='formatted')

        iflag = 0
        nlev = 1
        dumm=99999.9

        isurf = 0
        ibogus = 0
        ter = dumm
        dslp= dumm
         date='MMMMMMMMMM'
         mins='MM'
          pr=dumm
          zx=dumm
          tt=dumm
          td=dumm
          d=dumm
          v=dumm

C*      Identify BUFR file to the BUFRLIB software.  DX BUFR tables
C*      are embedded within the first few messages of the BUFR file
C*      itself, thus we logical unit for the BUFR tables file is the
C*      same as the BUFR file itself.

        CALL OPENBF  ( 11, 'IN', 11 )

C*      Specify that we would like IDATE values returned using 10 digits
C*      (i.e. YYYYMMDDHHMM ).

        CALL DATELEN  ( 10 )

C*-----------------------------------------------------------------------
        DO WHILE  ( .true. )

C*          Read the next BUFR message.

           call readns(11, csubset, idate, ierr)

c            write(*,*)' idate: ',idate,'  ',csubset

            IF  ( ierr .ne.  0 )  THEN
                write(*,*) '[decode_satwnd]....all records read, Exit'
                CALL CLOSBF  ( 11 )
                Goto 2000
            END IF

C*            At this point, we have a data subset within the
C*            internal arrays of BUFRLIB, and we can now begin
C*            reading actual data values:

              CALL UFBINT (11, r8arr,  MXMN, MXLV, nlv, ostr(1))
              CALL UFBINT (11, r8arr2, MXMN, MXLV, nlv, ostr(2))
              CALL UFBINT (11, r8arr3, MXMN, MXLV, nlv, ostr(3))
              CALL UFBINT (11, r8arr4, MXMN, MXLV, nlv, ostr(4))

            minu = int(r8arr3(2,1))
            write (unit=minute, FMT='(I2)') minu

            DO k=1,2
               IF (minute (k:k) .eq. ' ') THEN
                 minute (k:k) = '0'
               ENDIF
            ENDDO

            DO z = 1,nlv
c              WRITE (UNIT=outstg, FMT='(I10,1x,A8,3(1X,F5.1),1X,
c     +               A8,1X,F5.1,1X,F4.1,1X,F6.1,4(1x,F4.1),
c     +               2(1X,F7.2),1X,F6.2,1X,F7.1,1X,F5.1,1x,F6.2)')
c     +               idate,csubset,
c     +               (r8arr(i,z), i = 1,4),(r8arr2(i,z), i = 1,5),
c     +               (r8arr3(i,z), i = 1,4),(r8arr4(i,z), i = 1,4)

              WRITE (UNIT=outstg, FMT='(I10,1x,A8,1X,F5.1,1X,
     +               A8,1X,F5.1,1X,F4.1,1X,F6.1,4(1x,F4.1),
     +               2(1X,F7.2),1X,F6.2,1X,F7.1,1X,F5.1,1x,F6.2)')
     +               idate,csubset,
     +               (r8arr(i,z), i = 1,2),(r8arr2(i,z), i = 1,5),
     +               (r8arr3(i,z), i = 1,4),(r8arr4(i,z), i = 1,4)

              DO y = 1,200
               IF ( outstg (y:y) .eq. '*') THEN
                 outstg (y:y) = 'm'
               ENDIF
              ENDDO

              read(outstg, 21, end=2000) M10,M1,M2,M3,M4,M5,M6
              read(minute, 22) M11

c 21            format(A10,76X,A6,1X,A7,1X,A6,1X,A7,1X,A5,2X,A5)
21            format(A10,64X,A6,1X,A7,1X,A6,1X,A7,1X,A5,2X,A5)
22            format(A2)

C*-----------------------------------------------------------------------
c         Prepare output

              CALL READMval(M1, lat)
              CALL READMval(M2, lon)
              CALL READMval(M3, tt)
              CALL READMval(M4, pr)
              CALL READMval(M5, d)
              CALL READMval(M6, v)

              date = M10
              mins = M11

              if(pr .ne. 0 .and. pr < 99999 ) then
                pr= pr/100
              end if

c        write to output file
              if (iflag.eq.0) then
                write(iou,fmt='(a10)') date_tag
                iflag=1
              endif
              if(slat<=lat .and. nlat>=lat .and. wlon<=lon .and.
     &        elon>=lon) then
                 write(iou,111)isurf,dname,dname,date,mins,
     &                         lat,lon,ter,dslp,nlev,ibogus
                 write(iou,112)pr,zx,tt,td,d,v
              endif
111      format(i1,2(1x,a6),1x,a10,a2,4(f7.1,1x),i3,1x,i1)
112      format(6(f7.1,1x))

         print '(A132)', outstg

            END DO
        END DO

C*-----------------------------------------------------------------------
2000    stop 99999

        END

C*-----------------------------------------------------------------------
      SUBROUTINE READMval(M1,fl)
           character*8 M1
           dumm=99999.9
           if(M1(1:1) ==  'm') then
               fl = dumm
           else
               read(M1,*)fl
           endif

       RETURN
         END