      SUBROUTINE SUBINT(IQ,I10)
*
*
*       Decision-making for subsystems.
*       -------------------------------
*
      INCLUDE 'common6.h'
      COMMON/CLUMP/   BODYS(NCMAX,5),T0S(5),TS(5),STEPS(5),RMAXS(5),
     &                NAMES(NCMAX,5),ISYS(5)
      COMMON/IHIST/ IBIN(1000)
      COMMON/KSPAR/ ISTAT(KMAX)
      INTEGER LISTKS(KMAX),NEXTL(KMAX)
      PARAMETER (NLMAX=3)
      SAVE IB,LY,NK
      DATA IB,LY /0,0/
*     SAVE COMP,TT1
*     DATA COMP /0.0D0/
*
*
*     TT1 = DBLTIM()  ! Needs wtime.o from GPU2 (also in Makefile)
*       Initialize the parallel KS counters.
      IF (IB.EQ.0) THEN
          DO 1 K = 1,1000
              IBIN(K) = 0
    1     CONTINUE
          IB = 1
      END IF
*
*       See whether to advance any KS solutions at start of block-step.
      IF (NPAIRS.GT.0) THEN
*       Make a list of all members due up to end of block-step.
          I1 = -1
          NK = 0
          DO 2 IP = 1,NPAIRS
            I1 = I1 + 2
            IF (T0(I1) + STEP(I1).LE.TBLOCK) THEN
              NK = NK + 1
              LISTKS(NK) = I1
            END IF
    2     CONTINUE
*
*       Determine quantized value of TMIN (next small block-step).
    5     TMIN = TBLOCK
          DO 6 L = 1,NK
            I1 = LISTKS(L)
            TMIN = MIN(T0(I1) + STEP(I1),TMIN)
    6     CONTINUE
*
*       Update time and form list of binaries due at TMIN.
          TIME = TMIN
          LENGTH = 0
          DO 8 L = 1,NK
            I1 = LISTKS(L)
            IF (T0(I1) + STEP(I1).EQ.TMIN) THEN
              LENGTH = LENGTH + 1
              NEXTL(LENGTH) = I1
            END IF
    8     CONTINUE
*
*       Check possible chain integration on zero LENGTH.
          IF (LENGTH.EQ.0) THEN
            GO TO 30
          END IF
*
*       Clean current length of ISTAT.
          DO 9 L = 1,LENGTH
            ISTAT(L) = 0
    9     CONTINUE
*
*       Begin KS integration (sequential or parallel).
          IF (LENGTH.LE.NLMAX) THEN
            DO 10 LI = 1,LENGTH
              I1 = NEXTL(LI)
              CALL KSINT(I1,LI)
   10       CONTINUE
*
*       Search non-zero flags (ISTAT < 0 means collision).
            IF (IQ.EQ.0) THEN
              DO 12 LI = 1,LENGTH
                IF (ISTAT(LI).NE.0) THEN
                  IQ = ISTAT(LI)
                  I10 = NEXTL(LI)
                  KSPAIR = KVEC(I10)
*       Note IPHASE must be defined for chain (not needed for collision).
                  IPHASE = IQ
                  GO TO 15
                END IF
   12         CONTINUE
            END IF
*
*       Treat collision explicitly before quitting (suppressed in KSINT).
   15       IF (IQ.LT.0) THEN
              IP = KVEC(I10)
              KSPAIR = IP
              QPERI = R(IP)
              IQCOLL = -2
              CALL CMBODY(QPERI,2)
*       Ensure block-step time for normal continuation.
              TIME = TBLOCK
*       Note rest of the block will be done next time (need GO TO 999 first).
              GO TO 60
            END IF
*       Complete all block-steps before special procedure (except coll).
            IF (TMIN.LT.TBLOCK) GO TO 5
*
            TIME = TBLOCK
          ELSE
*
*       Perform the parallel execution loop.
!$omp parallel do private(LI,I1)
            DO 20 LI = 1,LENGTH
              I1 = NEXTL(LI)
              CALL KSINTP(I1,LI)
   20       CONTINUE
!$omp end parallel do
*       Note that unperturbed KS are now included in parallel step counter.
            NSTEPU = NSTEPU + LENGTH
*
*       Search non-zero flags (ISTAT < 0 for collision).
            IF (IQ.EQ.0) THEN
              DO 25 LI = 1,LENGTH
                IF (ISTAT(LI).NE.0) THEN
                  IQ = ISTAT(LI)
                  I10 = NEXTL(LI)
                  IPHASE = IQ
                  KSPAIR = KVEC(I10)  ! might be needed somewhere.
                  GO TO 28
                END IF
   25         CONTINUE
            END IF
*
*       Treat collision explicitly before quitting (suppressed in KSINTP).
   28       IF (IQ.LT.0) THEN
              IP = KVEC(I10)
              KSPAIR = IP
              QPERI = R(IP)
              IQCOLL = -2
              CALL CMBODY(QPERI,2)
*       Note rest of the block will be done next time (need GO TO 999 first).
              GO TO 60
            END IF
*
*       Check more block-step levels unless collision (final exit at TBLOCK).
            IF (TMIN.LT.TBLOCK) GO TO 5
          END IF
*       Copy original block time at end of KS treatment.
          TIME = TBLOCK
      END IF
*
*       Check time for advancing any triple, quad or chain regularization.
   30 IF (NSUB.GT.0) THEN
   40     TSUB = 1.0D+10
          DO 45 L = 1,NSUB
              IF (TS(L).LT.TSUB) THEN
                  ISUB = L
                  TSUB = TS(L)
              END IF
   45     CONTINUE
*
          IF (TSUB.LE.TBLOCK) THEN
              TIME = TSUB
*       Decide between triple, quad or chain.
              IF (ISYS(ISUB).EQ.1) THEN
*       Update unperturbed size of subsystem and copy c.m. step.
                  CALL EXTEND(ISUB)
                  CALL TRIPLE(ISUB)
              ELSE IF (ISYS(ISUB).EQ.2) THEN
                  CALL EXTEND(ISUB)
                  CALL QUAD(ISUB)
              ELSE
                  IF (STEPS(ISUB).LT.0.0D0) THEN
                      STEPS(ISUB) = 1.0D-10
                      GO TO 50
                  END IF
                  CALL CHAIN(ISUB)
                  IF (ISUB.GT.0) THEN
                      IF (STEPS(ISUB).LT.0.0D0) THEN
                          STEPS(ISUB) = 1.0D-10
                          GO TO 50
                      END IF
                  END IF
              END IF
*
*       Check for termination (set TPREV < TIME and set IQ < 0).
              IF (ISUB.LT.0.OR.IPHASE.LT.0) THEN
                  TPREV = TIME - STEP(NTOT)
                  IQ = -1
              END IF
              GO TO 40
          END IF
   50     TIME = TBLOCK
      END IF
*
*     TT2 = DBLTIM()
*     COMP = COMP + (TT2 - TT1)
*     IF (ABS(TIME-TCRIT).LT.1.0D-05) WRITE (6,70)  COMP
*  70 FORMAT (' SUBINT   ',1P,E12.3)
*
   60 RETURN
*
      END


         SUBROUTINE ZRCCR3(CCR3,DET,ISTAT)
*
*  Module number:
*
*  Module name: ZRCCR3
*
*  Keyphrase:
*  ----------
*       Read table ccr3 (GHRS detector parameters)
*
*  Description:
*  ------------
*       This routine reads table CCR3 and extracts the parameters
*       for the specified detector.
*
*  FORTRAN name: zrccr3
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       CCR3                    I       detector parameter table
*
*  Subroutines Called:
*  -------------------
*  SDAS:
*       ZMSPUT, uttopn, utpgti, utcfnd, utrgt*, uttclo
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       Feb 89  D. Lindler      Designed and coded
*-------------------------------------------------------------------------------
*
* Input parameters
*
*       ccr3 - table name (character*64)
*       det - detector number (integer)
*
* Output parameters
*
*       istat - ERROR status (integer)
**************************************************************************
        CHARACTER*64 CCR3
        INTEGER DET
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C     THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O.
C
C
C     THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET:
C
C                                       NUMBER OF ROWS WRITTEN TO
      INTEGER   TBNROW
      PARAMETER (TBNROW = 21)
C
C                       /CCR3PR/
C
C Common block for HRS parameters from table ccr3
C
        INTEGER S0,C1,C2,SKYMNF,SKYMDF,INTMNF,INTMDF,SKYORD,INTORD
        REAL C,MINDIO,MINPHC,MINECH,MINABS,DELTAT,RATIO,PERIOD
        COMMON /CCR3PR/ PERIOD,S0,C,C1,C2,SKYMNF,SKYMDF,SKYORD,
     *                  INTMNF,INTMDF,INTORD,MINDIO,MINPHC,MINECH,
     *                  MINABS,DELTAT,RATIO
C
C	period - orbital period in minutes
C       s0 - sample position center of the photocathode (integer)
C       c - conversion factor from sample units to millimeters (real)
C       c1 - diode offset to center of left background diodes (integer)
C       c2 - diode offset to center of right background diodes (integer)
C       skymnf - mean filter for sky spectra (integer)
C       skymdf - median filter for sky spectra (integer)
C       skyord - order of polynomial to fit to sky spectra (integer)
C       intmnf - mean filter for interorder spectra (integer)
C       intmdf - median filter for interorder spectra (integer)
C       intord - order of polynomial to fit to interorder spectra (integer)
C       mindio - minimum diode response to use (real)
C       minphc - minimum photocathode response to use (real)
C       minech - minimum echelle ripple value to use (real)
C       minabs - minimum abs. sens. value to use (real)
C       deltat - time increment for updating doppler comp. positions
C               in 125 millisec. units (real)
C       ratio - ratio of LSA size/SSA size
C
C LOCAL VARIABLES -------------------------------------------
C
        INTEGER IDIN,NROWS,COLIDS(18),ROW,IDET,I,ISTATS(18)
        CHARACTER*80 CONTXT
        CHARACTER*15 COLNAM(18)
        LOGICAL NULL
        DATA COLNAM/'DETECTOR','S0','C','C1','C2',
     *                  'SKY_MNFWIDTH','SKY_MDFWIDTH','SKY_ORDER',
     *			'INT_MNFWIDTH','INT_MDFWIDTH','INT_ORDER',
     *			'MIN_DIO','MIN_PHC','MIN_ECH',
     *                  'MIN_ABS','DELTA_T','AP_RATIO','PERIOD'/
C
C--------------------------------------------------------------------------
C
C Open table
C
        CALL UTTOPN(CCR3,RDONLY,IDIN,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR opening ccr3 table '//CCR3
                GO TO 998
        ENDIF
C
C get number of rows
C
        CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR reading ccr3 table '//CCR3
                GO TO 999
        ENDIF
C
C Get column ids.
C
        CALL UTCFND(IDIN,COLNAM,18,COLIDS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR locating needed columns in ccr3 table '//
     *                  CCR3
                GO TO 999
        ENDIF
C
C Locate row with correct detector number
C
        DO 10 ROW=1,NROWS
                CALL UTRGTI(IDIN,COLIDS(1),1,ROW,IDET,NULL,ISTAT)
                IF(ISTAT.NE.0)THEN
                        CONTXT='ERROR reading ccr3 table '//CCR3
                        GO TO 999
                ENDIF
                IF(DET.EQ.IDET)GO TO 20
10      CONTINUE
C
C if we made it here, we did not find a correct row
C
        WRITE(CONTXT,99)DET
99      FORMAT('ERROR no row in ccr3 table found for detector ',I2)
        GO TO 999
C
C read values
C
20      CALL UTRGTI(IDIN,COLIDS(2),1,ROW,S0,NULL,ISTATS(1))
        CALL UTRGTR(IDIN,COLIDS(3),1,ROW,C,NULL,ISTATS(2))
        CALL UTRGTI(IDIN,COLIDS(4),1,ROW,C1,NULL,ISTATS(3))
        CALL UTRGTI(IDIN,COLIDS(5),1,ROW,C2,NULL,ISTATS(4))
        CALL UTRGTI(IDIN,COLIDS(6),1,ROW,SKYMNF,NULL,ISTATS(5))
        CALL UTRGTI(IDIN,COLIDS(7),1,ROW,SKYMDF,NULL,ISTATS(6))
        CALL UTRGTI(IDIN,COLIDS(8),1,ROW,SKYORD,NULL,ISTATS(7))
        CALL UTRGTI(IDIN,COLIDS(9),1,ROW,INTMNF,NULL,ISTATS(8))
        CALL UTRGTI(IDIN,COLIDS(10),1,ROW,INTMDF,NULL,ISTATS(9))
        CALL UTRGTI(IDIN,COLIDS(11),1,ROW,INTORD,NULL,ISTATS(10))
        CALL UTRGTR(IDIN,COLIDS(12),1,ROW,MINDIO,NULL,ISTATS(11))
        CALL UTRGTR(IDIN,COLIDS(13),1,ROW,MINPHC,NULL,ISTATS(12))
        CALL UTRGTR(IDIN,COLIDS(14),1,ROW,MINECH,NULL,ISTATS(13))
        CALL UTRGTR(IDIN,COLIDS(15),1,ROW,MINABS,NULL,ISTATS(14))
        CALL UTRGTR(IDIN,COLIDS(16),1,ROW,DELTAT,NULL,ISTATS(15))
        CALL UTRGTR(IDIN,COLIDS(17),1,ROW,RATIO,NULL,ISTATS(16))
        CALL UTRGTR(IDIN,COLIDS(18),1,ROW,PERIOD,NULL,ISTATS(17))
        DO 30 I=1,17
            IF(ISTATS(I).NE.0)THEN
                CONTXT='ERROR reading ccr3 table '//CCR3
                GO TO 999
            ENDIF
30      CONTINUE
        CALL UTTCLO(IDIN,ISTAT)
        ISTAT=0
        GO TO 1000
999     CALL UTTCLO(IDIN,ISTAT)
998     CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END


module grid_geometry_specific

  use core_lib
  use mpi_core
  use mpi_hdf5_io
  use type_photon
  use type_grid_cell
  use type_grid
  use grid_io
  use counters

  implicit none
  save

  private

  ! Photon position routines
  public :: cell_width
  public :: grid_geometry_debug
  public :: find_cell
  public :: place_in_cell
  public :: in_correct_cell
  public :: random_position_cell
  public :: find_wall
  public :: distance_to_closest_wall

  logical :: debug = .false.

  public :: escaped
  interface escaped
     module procedure escaped_photon
     module procedure escaped_cell
  end interface escaped

  public :: next_cell
  interface next_cell
     module procedure next_cell_int
     module procedure next_cell_wall_id
  end interface next_cell

  ! Oct cell organization:
  ! subcell 1: (0,0,0)
  ! subcell 2: (1,0,0)
  ! subcell 3: (0,1,0)
  ! subcell 4: (1,1,0)
  ! subcell 5: (0,0,1)
  ! subcell 6: (1,0,1)
  ! subcell 7: (0,1,1)
  ! subcell 8: (1,1,1)

  ! The following array gives the opposite cell for a given subcell and
  ! wall id. The call signature is (subcell_id, wall_id)
  integer,parameter :: opposite_cell(8,6) = reshape((/0,1,0,3,0,5,0,7,&
       &                                              2,0,4,0,6,0,8,0,&
       &                                              0,0,1,2,0,0,5,6,&
       &                                              3,4,0,0,7,8,0,0,&
       &                                              0,0,0,0,1,2,3,4,&
       &                                              5,6,7,8,0,0,0,0&
       &                                              /),(/8,6/))

  public :: setup_grid_geometry
  type(grid_geometry_desc),public,target :: geo

  integer :: n_filled = 0

contains

  real(dp) function cell_width(cell, idir)
    implicit none
    type(grid_cell),intent(in) :: cell
    integer,intent(in) :: idir
    select case(idir)
    case(1)
       cell_width = geo%cells(cell%ic)%dx * 2._dp
    case(2)
       cell_width = geo%cells(cell%ic)%dy * 2._dp
    case(3)
       cell_width = geo%cells(cell%ic)%dz * 2._dp
    end select
  end function cell_width

  real(dp) function cell_area(cell, iface)
    implicit none
    type(grid_cell),intent(in) :: cell
    integer,intent(in) :: iface
    select case(iface)
    case(1,2)
       cell_area = geo%cells(cell%ic)%dy * geo%cells(cell%ic)%dz * 4._dp
    case(3,4)
       cell_area = geo%cells(cell%ic)%dz * geo%cells(cell%ic)%dx * 4._dp
    case(5,6)
       cell_area = geo%cells(cell%ic)%dx * geo%cells(cell%ic)%dy * 4._dp
    end select
  end function cell_area

  ! Octree Helper Routines

  integer function subcell_id(cell_id, r)
    ! Given a cell and a position falling in the cell, find the sub-cell
    ! that the position would fall into
    implicit none
    integer,intent(in) :: cell_id
    type(vector3d_dp),intent(in) :: r
    if(r%x < geo%cells(cell_id)%x) then
       if(r%y < geo%cells(cell_id)%y) then
          if(r%z < geo%cells(cell_id)%z) then
             subcell_id = 1
          else
             subcell_id = 5
          end if
       else
          if(r%z < geo%cells(cell_id)%z) then
             subcell_id = 3
          else
             subcell_id = 7
          end if
       end if
    else
       if(r%y < geo%cells(cell_id)%y) then
          if(r%z < geo%cells(cell_id)%z) then
             subcell_id = 2
          else
             subcell_id = 6
          end if
       else
          if(r%z < geo%cells(cell_id)%z) then
             subcell_id = 4
          else
             subcell_id = 8
          end if
       end if
    end if
  end function subcell_id

  recursive integer function locate_cell(r, cell_id) result(final_cell_id)
    implicit none
    type(vector3d_dp), intent(in) :: r
    integer,intent(in) :: cell_id
    integer :: new_cell_id
    if(geo%cells(cell_id)%refined) then
       new_cell_id = geo%cells(cell_id)%children(subcell_id(cell_id, r))
       final_cell_id = locate_cell(r, new_cell_id)
    else
       final_cell_id = cell_id
    end if
  end function locate_cell

  recursive subroutine octree_setup_indiv(parent_id)

    ! Set up a cell that has already had the refinement flag set

    implicit none

    integer,intent(in) :: parent_id
    integer :: sx, sy, sz
    integer :: ic, child_id

    allocate(geo%cells(parent_id)%children(8))

    do ic=1,8

       n_filled = n_filled + 1
       child_id = n_filled
       geo%cells(parent_id)%children(ic) = child_id

       sx = 1 ; sy = 1 ; sz = 1
       if(mod(ic-1,2)==0) sx = -sx
       if(mod(ic-1-mod(ic-1,2),4)/2==0) sy = -sy
       if(mod(ic-1-mod(ic-1,2)-mod(ic-1-mod(ic-1,2),4),8)/4==0) sz = -sz

       geo%cells(child_id)%x = geo%cells(parent_id)%x + sx * geo%cells(parent_id)%dx/2._8
       geo%cells(child_id)%y = geo%cells(parent_id)%y + sy * geo%cells(parent_id)%dy/2._8
       geo%cells(child_id)%z = geo%cells(parent_id)%z + sz * geo%cells(parent_id)%dz/2._8
       geo%cells(child_id)%dx = geo%cells(parent_id)%dx / 2._dp
       geo%cells(child_id)%dy = geo%cells(parent_id)%dy / 2._dp
       geo%cells(child_id)%dz = geo%cells(parent_id)%dz / 2._dp

       geo%cells(child_id)%parent = parent_id
       geo%cells(child_id)%parent_subcell = ic

       if(geo%cells(child_id)%refined) call octree_setup_indiv(child_id)

    end do

  end subroutine octree_setup_indiv

  ! Standard Routines

  subroutine setup_grid_geometry(group)

    ! Read an octree from an HDF5 file

    implicit none

    integer(hid_t),intent(in) :: group

    real(dp) :: x, y, z, dx, dy, dz
    integer :: ic, iv

    ! FIX - issue with reading 64-bit 1D column with 32-bit variables
    integer, allocatable :: refined(:)

    ! Read geometry file
    call mp_read_keyword(group, '.', "geometry", geo%id)
    call mp_read_keyword(group, '.', "grid_type", geo%type)

    ! Read in refinement list
    call mp_table_read_column_auto(group, 'cells', 'refined', refined)

    ! Find number of cells
    geo%n_cells = size(refined)

    ! Figure out which cells are valid, and construct an index to map valid
    ! cell IDs to original IDs
    geo%masked = .true.
    allocate(geo%mask(geo%n_cells))
    geo%mask = refined == 0
    geo%n_masked = count(geo%mask)
    allocate(geo%mask_map(geo%n_masked))
    iv = 0
    do ic=1,geo%n_cells
       if(geo%mask(ic)) then
          iv = iv + 1
          geo%mask_map(iv) = ic
       end if
    end do

    ! Allocate cells
    allocate(geo%cells(geo%n_cells))

    ! Assigned refined values to all cells
    do ic=1,geo%n_cells
       geo%cells(ic)%refined = refined(ic) == 1
    end do

    ! Read parameters for top-level cell
    call mp_read_keyword(group, '.', 'x', geo%cells(1)%x)
    call mp_read_keyword(group, '.', 'y', geo%cells(1)%y)
    call mp_read_keyword(group, '.', 'z', geo%cells(1)%z)
    call mp_read_keyword(group, '.', 'dx', geo%cells(1)%dx)
    call mp_read_keyword(group, '.', 'dy', geo%cells(1)%dy)
    call mp_read_keyword(group, '.', 'dz', geo%cells(1)%dz)

    n_filled=1

    ! Recursively set up cells
    if(geo%cells(1)%refined) call octree_setup_indiv(1)

    allocate(geo%volume(geo%n_cells))

    ! Compute cell volumes
    do ic=1,geo%n_cells
       geo%volume(ic) = geo%cells(ic)%dx * geo%cells(ic)%dy * geo%cells(ic)%dz * 8._dp
    end do

    if(any(geo%volume==0._dp)) call error('setup_grid_geometry','all volumes should be greater than zero')

    geo%n_dim = 3

    geo%xmin = geo%cells(1)%x - geo%cells(1)%dx
    geo%xmax = geo%cells(1)%x + geo%cells(1)%dx
    geo%ymin = geo%cells(1)%y - geo%cells(1)%dy
    geo%ymax = geo%cells(1)%y + geo%cells(1)%dy
    geo%zmin = geo%cells(1)%z - geo%cells(1)%dz
    geo%zmax = geo%cells(1)%z + geo%cells(1)%dz

  end subroutine setup_grid_geometry

  subroutine grid_geometry_debug(debug_flag)
    implicit none
    logical,intent(in) :: debug_flag
    debug = debug_flag
  end subroutine grid_geometry_debug

  type(grid_cell) function find_cell(p) result(icell)
    implicit none
    type(photon),intent(in) :: p
    integer :: ic
    if(debug) write(*,'(" [debug] find_cell")')
    if(p%r%x<geo%xmin.or.p%r%y>geo%xmax) then
       call warn("find_cell","photon not in grid (in x direction)")
       icell = invalid_cell
       return
    end if
    if(p%r%y<geo%ymin.or.p%r%y>geo%ymax) then
       call warn("find_cell","photon not in grid (in y direction)")
       icell = invalid_cell
       return
    end if
    if(p%r%z<geo%zmin.or.p%r%y>geo%zmax) then
       call warn("find_cell","photon not in grid (in z direction)")
       icell = invalid_cell
       return
    end if
    ic = locate_cell(p%r, 1)
    icell = new_grid_cell(ic, geo)
  end function find_cell

  subroutine place_in_cell(p)
    implicit none
    type(photon),intent(inout) :: p
    p%icell = find_cell(p)
    if(p%icell == invalid_cell) then
       call warn("place_in_cell","place_in_cell failed - killing")
       killed_photons_geo = killed_photons_geo + 1
       p%killed = .true.
    else
       p%in_cell = .true.
    end if
  end subroutine place_in_cell

  logical function escaped_photon(p)
    implicit none
    type(photon),intent(in) :: p
    escaped_photon = escaped_cell(p%icell)
  end function escaped_photon

  logical function escaped_cell(cell)
    implicit none
    type(grid_cell),intent(in) :: cell
    escaped_cell = .true.
    if(cell%ic == geo%n_cells + 1) return
    escaped_cell = .false.
  end function escaped_cell

  recursive type(grid_cell) function next_cell_int(cell, direction, intersection) result(c)
    implicit none
    type(grid_cell),intent(in) :: cell
    integer,intent(in) :: direction
    type(vector3d_dp),optional,intent(in) :: intersection
    type(grid_cell) :: parent_cell
    integer :: subcell_id
    if(cell%ic==1) then
       c = new_grid_cell(geo%n_cells+1, geo)
       return
    end if
    subcell_id = opposite_cell(geo%cells(cell%ic)%parent_subcell, direction)
    parent_cell = new_grid_cell(geo%cells(cell%ic)%parent, geo)
    if(subcell_id > 0) then
       c = new_grid_cell(locate_cell(intersection, geo%cells(parent_cell%ic)%children(subcell_id)),geo)
    else
       c = next_cell_int(parent_cell, direction, intersection)
       return
    end if
  end function next_cell_int

  type(grid_cell) function next_cell_wall_id(cell, direction, intersection)
    implicit none
    type(grid_cell),intent(in) :: cell
    type(wall_id),intent(in) :: direction
    type(vector3d_dp),optional,intent(in) :: intersection
    if(direction%w1 == -1) then
       next_cell_wall_id = next_cell_int(cell, 1, intersection)
    else if(direction%w1 == +1) then
       next_cell_wall_id = next_cell_int(cell, 2, intersection)
    else if(direction%w2 == -1) then
       next_cell_wall_id = next_cell_int(cell, 3, intersection)
    else if(direction%w2 == +1) then
       next_cell_wall_id = next_cell_int(cell, 4, intersection)
    else if(direction%w3 == -1) then
       next_cell_wall_id = next_cell_int(cell, 5, intersection)
    else if(direction%w3 == +1) then
       next_cell_wall_id = next_cell_int(cell, 6, intersection)
    end if
  end function next_cell_wall_id

  logical function in_correct_cell(p)
    implicit none
    type(photon),intent(in) :: p
    type(grid_cell) :: curr
    type(grid_cell) :: icell_actual
    real(dp) :: frac,frac1, frac2, frac3
    icell_actual = find_cell(p)
    if(p%on_wall) then
       frac1 = abs(p%r%x - geo%cells(p%icell%ic)%x) / geo%cells(p%icell%ic)%dx
       frac2 = abs(p%r%y - geo%cells(p%icell%ic)%y) / geo%cells(p%icell%ic)%dy
       frac3 = abs(p%r%z - geo%cells(p%icell%ic)%z) / geo%cells(p%icell%ic)%dz
       if(abs(p%on_wall_id%w1) == 1) then
          frac = frac1 - 1._dp
          in_correct_cell = frac2 < 1._dp .and. frac3 < 1._dp
       end if
       if(abs(p%on_wall_id%w2) == 1) then
          frac = frac2 - 1._dp
          in_correct_cell = frac1 < 1._dp .and. frac3 < 1._dp
       end if
       if(abs(p%on_wall_id%w3) == 1) then
          frac = frac3 - 1._dp
          in_correct_cell = frac1 < 1._dp .and. frac2 < 1._dp
       end if
       in_correct_cell = abs(frac) < 1.e-3_dp .and. in_correct_cell
    else
       in_correct_cell = icell_actual == p%icell
    end if
  end function in_correct_cell

  subroutine random_position_cell(icell,pos)
    implicit none
    type(grid_cell),intent(in) :: icell
    type(vector3d_dp), intent(out) :: pos
    real(dp) :: x,y,z
    call random(x)
    call random(y)
    call random(z)
    pos%x = (2._dp*x - 1._dp) * geo%cells(icell%ic)%dx + geo%cells(icell%ic)%x
    pos%y = (2._dp*y - 1._dp) * geo%cells(icell%ic)%dy + geo%cells(icell%ic)%y
    pos%z = (2._dp*z - 1._dp) * geo%cells(icell%ic)%dz + geo%cells(icell%ic)%z
  end subroutine random_position_cell

  real(dp) function distance_to_closest_wall(p) result(d)

    implicit none

    type(photon),intent(in) :: p

    real(dp) :: d1,d2,d3,d4,d5,d6

    d1 = p%r%x - geo%cells(p%icell%ic)%x - geo%cells(p%icell%ic)%dx
    d2 = geo%cells(p%icell%ic)%x + geo%cells(p%icell%ic)%dx - p%r%x
    d3 = p%r%y - geo%cells(p%icell%ic)%y - geo%cells(p%icell%ic)%dy
    d4 = geo%cells(p%icell%ic)%y + geo%cells(p%icell%ic)%dy - p%r%y
    d5 = p%r%z - geo%cells(p%icell%ic)%z - geo%cells(p%icell%ic)%dz
    d6 = geo%cells(p%icell%ic)%z + geo%cells(p%icell%ic)%dz - p%r%z

    ! Find the smallest of the distances

    d = min(d1,d2,d3,d4,d5,d6)

    ! The closest distance should never be negative

    if(d < 0._dp) then
       call warn("distance_to_closest_wall","distance to closest wall is negative (assuming zero)")
       d = 0._dp
    end if

  end function distance_to_closest_wall

  subroutine find_wall(p,radial,tmin,id_min)

    implicit none

    type(photon), intent(inout) :: p
    ! Position and direction

    logical,intent(in) :: radial

    type(wall_id),intent(out) :: id_min
    ! ID of next wall

    real(dp),intent(out)  :: tmin
    ! tmin to nearest wall

    real(dp) :: tx, ty, tz

    logical :: pos_vx, pos_vy, pos_vz

    ! Can store this in photon, because it only changes at each interaction
    pos_vx = p%v%x > 0._dp ! whether photon is moving in the +ve x direction
    pos_vy = p%v%y > 0._dp ! whether photon is moving in the +ve y direction
    pos_vz = p%v%z > 0._dp ! whether photon is moving in the +ve z direction

    ! Store inv_v to go faster
    if(pos_vx) then
       tx = ( geo%cells(p%icell%ic)%x + geo%cells(p%icell%ic)%dx - p%r%x ) / p%v%x
    else if(p%v%x < 0._dp) then
       tx = ( geo%cells(p%icell%ic)%x - geo%cells(p%icell%ic)%dx - p%r%x ) / p%v%x
    else
       tx = huge(1._dp)
    end if

    if(pos_vy) then
       ty = ( geo%cells(p%icell%ic)%y + geo%cells(p%icell%ic)%dy - p%r%y ) / p%v%y
    else if(p%v%y < 0._dp) then
       ty = ( geo%cells(p%icell%ic)%y - geo%cells(p%icell%ic)%dy - p%r%y ) / p%v%y
    else
       ty = huge(1._dp)
    end if

    if(pos_vz) then
       tz = ( geo%cells(p%icell%ic)%z + geo%cells(p%icell%ic)%dz - p%r%z ) / p%v%z
    else if(p%v%z < 0._dp) then
       tz = ( geo%cells(p%icell%ic)%z - geo%cells(p%icell%ic)%dz - p%r%z ) / p%v%z
    else
       tz = huge(1._dp)
    end if

    ! Following is potential slowdown, in fact, could just test tmin after
    if(min(tx,ty,tz) .lt. 0._dp) call error("find_wall","negative t")

    ! Find the closest of the three walls. The following effectively
    ! finds the minimum of three values. A lot of code for such a
    ! small thing, but this runs much much faster than using a built
    ! in min function or any kind of loop. Each iteraction comprises only
    ! three if statements and two pointer assignements.

    if(tx.lt.tz) then
       if(tx.lt.ty) then
          if(pos_vx) then
             id_min%w1 = +1
          else
             id_min%w1 = -1
          end if
          tmin = tx
       else
          if(pos_vy) then
             id_min%w2 = +1
          else
             id_min%w2 = -1
          end if
          tmin = ty
       end if
    else
       if(tz.lt.ty) then
          if(pos_vz) then
             id_min%w3 = +1
          else
             id_min%w3 = -1
          end if
          tmin = tz
       else
          if(pos_vy) then
             id_min%w2 = +1
          else
             id_min%w2 = -1
          end if
          tmin = ty
       end if
    end if

  end subroutine find_wall

end module grid_geometry_specific


module GrapeClass
    use LeafClass
    use StemClass
    use RootClass
    implicit none

    type :: Grape_

        ! 節-節点データ構造
        type(Mesh_) :: struct
        integer(int32),allocatable :: leaf2stem(:,:)
        integer(int32),allocatable :: stem2stem(:,:)
        integer(int32),allocatable :: root2stem(:,:)
        integer(int32),allocatable :: root2root(:,:)

        real(real64)   :: mainstem_length
        real(real64)   :: mainstem_width
        integer(int32) :: mainstem_node

        real(real64)   :: mainroot_length
        real(real64)   :: mainroot_width
        integer(int32) :: mainroot_node

        integer(int32) :: num_branch
        integer(int32) :: num_branch_node

        integer(int32) :: num_branch_root
        integer(int32) :: num_branch_root_node

        real(real64) :: ms_angle_ave = 0.0d0
        real(real64) :: ms_angle_sig = 0.0d0
        real(real64),allocatable :: br_angle_ave_x(:)
        real(real64),allocatable :: br_angle_sig_x(:)
        real(real64),allocatable :: br_angle_ave_z(:)
        real(real64),allocatable :: br_angle_sig_z(:)

        real(real64),allocatable :: peti_size_ave(:)
        real(real64),allocatable :: peti_size_sig(:)
        real(real64),allocatable :: peti_width_ave(:)
        real(real64),allocatable :: peti_width_sig(:)
        real(real64),allocatable :: peti_angle_ave(:)
        real(real64),allocatable :: peti_angle_sig(:)

        real(real64),allocatable :: leaf_thickness_ave(:)
        real(real64),allocatable :: leaf_thickness_sig(:)
        real(real64),allocatable :: leaf_angle_ave(:)
        real(real64),allocatable :: leaf_angle_sig(:)
        real(real64),allocatable :: leaf_length_ave(:)
        real(real64),allocatable :: leaf_length_sig(:)
        real(real64),allocatable :: leaf_width_ave(:)
        real(real64),allocatable :: leaf_width_sig(:)

        integer(int32),allocatable :: br_node(:)
        integer(int32),allocatable :: br_from(:)
        real(real64),allocatable :: br_length(:)
        real(real64),allocatable :: br_width(:)

        integer(int32) :: num_leaf
        integer(int32) :: num_stem
        integer(int32) :: num_root

        ! 器官オブジェクト配列
        type(FEMDomain_),allocatable :: leaf_list(:)
        type(FEMDomain_),allocatable :: stem_list(:)
        type(FEMDomain_),allocatable :: root_list(:)

        character(:),allocatable :: LeafSurfaceData
        type(Leaf_),allocatable :: Leaf(:)
        type(Stem_),allocatable :: Stem(:)
        type(Root_),allocatable :: Root(:)

    contains
        procedure :: create => createGrape
        procedure,public :: msh => mshGrape
        procedure,public :: vtk => vtkGrape
        procedure,public :: stl => stlGrape
        procedure,public :: json => jsonGrape
        procedure,public :: move => moveGrape
    end type
contains

! #############################################################
subroutine createGrape(obj,config)
    class(Grape_),intent(inout) :: obj
    character(*),intent(in) :: config
    character(:),allocatable :: line
    type(IO_) :: grapeconfig
    type(Random_) :: random
    integer(int32)::i,n,j,k,num_leaf,num_stem_node,num_branch_branch

    obj%LeafSurfaceData = trim(grapeconfig%parse(config,key1="LeafSurfaceData"))
    obj%mainstem_length = freal(grapeconfig%parse(config,key1="Mainstem",key2="Length"))
    obj%mainstem_width = freal(grapeconfig%parse(config,key1="Mainstem",key2="Width"))
    obj%mainstem_node = fint(grapeconfig%parse(config,key1="Mainstem",key2="Node"))
    obj%ms_angle_ave = freal(grapeconfig%parse(config,key1="Mainstem",key2="ms_angle_ave"))
    obj%ms_angle_sig = freal(grapeconfig%parse(config,key1="Mainstem",key2="ms_angle_sig"))

    ! get number of branch && number of node
    obj%num_branch=1
    obj%num_branch_node=0
    do
        line = grapeconfig%parse(config,key1="Branch#"//trim(str(obj%num_branch)),key2="Node" )
        if(len(trim(line))==0)then
            obj%num_branch = obj%num_branch -1
            exit
        else
            obj%num_branch = obj%num_branch  + 1
            obj%num_branch_node = obj%num_branch_node + fint(line)
            ! Further branch
            ! line = grapeconfig%parse(config,key1="Branch#"//trim(str(i)),key2="Branch#1")
            ! num_branch_branch = fint(line)
            ! if(num_branch_branch/=0)then
            !     ! 2nd order branch
            !     line = grapeconfig%parse(config,key1="Branch#"//trim(str(i)),key2="Branch#1")
            ! endif
            cycle
        endif
    enddo

    allocate(obj%br_node(obj%num_branch) )
    allocate(obj%br_from(obj%num_branch) )
    allocate(obj%br_length(obj%num_branch) )
    allocate(obj%br_width(obj%num_branch) )
    allocate(obj%br_angle_ave_x(obj%num_branch) )
    allocate(obj%br_angle_sig_x(obj%num_branch) )
    allocate(obj%br_angle_ave_z(obj%num_branch) )
    allocate(obj%br_angle_sig_z(obj%num_branch) )

    allocate(obj%peti_size_ave(obj%num_branch))
    allocate(obj%peti_size_sig(obj%num_branch))
    allocate(obj%peti_width_ave(obj%num_branch))
    allocate(obj%peti_width_sig(obj%num_branch))
    allocate(obj%peti_angle_ave(obj%num_branch))
    allocate(obj%peti_angle_sig(obj%num_branch))

    allocate(obj%leaf_thickness_ave(obj%num_branch))
    allocate(obj%leaf_thickness_sig(obj%num_branch))
    allocate(obj%leaf_angle_ave(obj%num_branch))
    allocate(obj%leaf_angle_sig(obj%num_branch))
    allocate(obj%leaf_length_ave(obj%num_branch))
    allocate(obj%leaf_length_sig(obj%num_branch))
    allocate(obj%leaf_width_ave(obj%num_branch))
    allocate(obj%leaf_width_sig(obj%num_branch))

    do i=1,obj%num_branch
        line = grapeconfig%parse(config,key1="Branch#"//trim(str(i)),key2="Node" )
        obj%br_node(i) = fint(line)
        line = grapeconfig%parse(config,key1="Branch#"//trim(str(i)),key2="From" )
        obj%br_from(i) = fint(line)
        line = grapeconfig%parse(config,key1="Branch#"//trim(str(i)),key2="Length" )
        obj%br_length(i) = freal(line)
        line = grapeconfig%parse(config,key1="Branch#"//trim(str(i)),key2="Width" )
        obj%br_width(i) = freal(line)
        obj%br_angle_ave_x(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="br_angle_ave_x"))
        obj%br_angle_ave_z(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="br_angle_ave_z"))
        obj%br_angle_sig_x(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="br_angle_sig_x"))
        obj%br_angle_sig_z(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="br_angle_sig_z"))
        obj%peti_size_ave(i)  = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="peti_size_ave"))
        obj%peti_size_sig(i)  = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="peti_size_sig"))
        obj%peti_width_ave(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="peti_width_ave"))
        obj%peti_width_sig(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="peti_width_sig"))
        obj%peti_angle_ave(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="peti_angle_ave"))
        obj%peti_angle_sig(i) = freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="peti_angle_sig"))

        obj%leaf_thickness_ave(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_thickness_ave"))
        obj%leaf_thickness_sig(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_thickness_sig"))
        obj%leaf_angle_ave(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_angle_ave"))
        obj%leaf_angle_sig(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_angle_sig"))
        obj%leaf_length_ave(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_length_ave"))
        obj%leaf_length_sig(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_length_sig"))
        obj%leaf_width_ave(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_width_ave"))
        obj%leaf_width_sig(i)= freal(grapeconfig%parse(&
            config,key1="Branch#"//trim(str(i)),key2="leaf_width_sig"))

    enddo

    obj%mainroot_length = freal(grapeconfig%parse(config,key1="Mainroot",key2="Length"))
    obj%mainroot_width = freal(grapeconfig%parse(config,key1="Mainroot",key2="Width"))
    obj%mainroot_node = fint(grapeconfig%parse(config,key1="Mainroot",key2="Node"))

    ! get number of branch && number of node
    obj%num_branch_root=1
    obj%num_branch_root_node=0
    do
        line = grapeconfig%parse(config,key1="Branchroot#"//trim(str(obj%num_branch_root)),key2="Node" )
        if(len(trim(line))==0)then
            obj%num_branch_root = obj%num_branch_root -1
            exit
        else
            obj%num_branch_root = obj%num_branch_root  + 1
            obj%num_branch_root_node = obj%num_branch_root_node + fint(line)
            cycle
        endif
    enddo

    obj%num_leaf =obj%num_branch_node + obj%mainstem_node
    obj%num_stem =obj%num_branch_node + obj%mainstem_node
    obj%num_root =obj%num_branch_root_node + obj%mainroot_node

    allocate(obj%leaf_list(obj%num_leaf))
    allocate(obj%stem_list(obj%num_stem))
    allocate(obj%root_list(obj%num_root))

    allocate(obj%leaf(obj%num_leaf*2))
    allocate(obj%stem(obj%num_stem*2))
    allocate(obj%root(obj%num_root*2))

    obj%leaf2stem = zeros( obj%num_leaf , obj%num_stem*2 )
    obj%stem2stem = zeros( obj%num_stem*2 , obj%num_stem*2 )
    obj%root2stem = zeros( obj%num_root , obj%num_stem*2 )
    obj%root2root = zeros( obj%num_root , obj%num_root )

    ! set mainstem
    do i=1,obj%mainstem_node

        call obj%stem(i)%init()
        call obj%stem(i)%resize(&
            x = obj%mainstem_width, &
            y = obj%mainstem_width, &
            z = obj%mainstem_length/dble(obj%mainstem_node) &
            )
        call obj%stem(i)%rotate(&
            x = radian(random%gauss(mu=obj%ms_angle_ave,sigma=obj%ms_angle_sig)),  &
            y = radian(random%gauss(mu=obj%ms_angle_ave,sigma=obj%ms_angle_sig)),  &
            z = radian(random%gauss(mu=obj%ms_angle_ave,sigma=obj%ms_angle_sig))   &
            )
    enddo

    do i=1,obj%mainstem_node-1
        call obj%stem(i+1)%connect("=>",obj%stem(i))
        obj%stem2stem(i+1,i) = 1
    enddo

    ! set branches
    k=obj%mainstem_node
    do i=1,size(obj%br_node)
        do j=1, obj%br_node(i)
            k = k + 1
            call obj%stem(k)%init()
            call obj%stem(k)%resize(&
                x = obj%br_width(i), &
                y = obj%br_width(i), &
                z = obj%br_length(i)/dble(obj%br_node(i) ) &
                )

            call obj%stem(k)%rotate(&
                x = radian(random%gauss(mu=obj%br_angle_ave_x(i),sigma=obj%br_angle_sig_x(i) )),  &
                y = 0.0d0,  &
                z = radian(random%gauss(mu=obj%br_angle_ave_z(i),sigma=obj%br_angle_sig_z(i) ))  &
                )

            if(j==1)then
                call obj%stem(k)%connect("=>",obj%stem(obj%br_from(i)  ))
                obj%stem2stem(k,obj%br_from(i) ) = 1
            else
                call obj%stem(k)%connect("=>",obj%stem(k-1))
                obj%stem2stem(k,k-1) = 1
            endif
        enddo
    enddo
!

        ! peti and leaf
    num_stem_node = k
    num_leaf = 0
    do i=1, size(obj%br_node)
        do j=1,obj%br_node(i)
            ! ３複葉
            ! add peti
            num_stem_node = num_stem_node +1
            call obj%stem(num_stem_node)%init()

            call obj%stem(num_stem_node)%resize(&
                x = random%gauss(mu=obj%peti_width_ave(i),sigma=obj%peti_width_sig(i)), &
                y = random%gauss(mu=obj%peti_width_ave(i),sigma=obj%peti_width_sig(i)), &
                z = random%gauss(mu=obj%peti_size_ave(i),sigma=obj%peti_size_sig(i)) &
                )

            call obj%stem(num_stem_node)%rotate(&
                x = radian(random%gauss(mu=obj%peti_angle_ave(i),sigma=obj%peti_angle_sig(i) )),  &
                y = 0.0d0,  &
                z = radian(360.0d0*random%random() )   &
                )

            !obj%leaf2stem(num_stem_node,i) = 1
            if(i==1)then
                call obj%stem(num_stem_node)%connect("=>",obj%stem( j + obj%mainroot_node))
                obj%stem2stem(num_stem_node, j + obj%mainroot_node ) = 1
            else
                call obj%stem(num_stem_node)%connect("=>",obj%stem( j + sum( obj%br_node(1:i-1) ) + obj%mainroot_node ))
                obj%stem2stem(num_stem_node, j + sum( obj%br_node(1:i-1) ) + obj%mainroot_node ) = 1
            endif

            ! add leaves

            num_leaf=num_leaf+1
            !call obj%leaf(num_leaf)%create(filename=trim(obj%LeafSurfaceData))
            call obj%leaf(num_leaf)%create(filename=trim(obj%LeafSurfaceData) )
            call obj%leaf(num_leaf)%femdomain%resize(&
                    z = random%gauss(mu=obj%leaf_thickness_ave(i),sigma=obj%leaf_thickness_sig(i))  , &
                    x = random%gauss(mu=obj%leaf_length_ave(i)   ,sigma=obj%leaf_length_sig(i)) , &
                    y = random%gauss(mu=obj%leaf_width_ave(i)    ,sigma=obj%leaf_width_sig(i)) &
                )
            call obj%leaf(num_leaf)%femdomain%rotate(&
                    x = radian(random%gauss(mu=obj%leaf_angle_ave(i),sigma=obj%leaf_angle_sig(i))), &
                    y = 0.0d0, &
                    z = radian(random%random()*360.0d0) &
                )
            call obj%leaf(num_leaf)%connect("=>",obj%stem(num_stem_node))
                obj%leaf2stem(num_leaf,num_stem_node) = 1
        enddo
    enddo

end subroutine
! #############################################################

! ########################################
subroutine mshGrape(obj,name,num_threads)
    class(Grape_),intent(inout) :: obj
    character(*),intent(in) :: name
    integer(int32),optional,intent(in) :: num_threads
    integer(int32) :: i,n

    n = input(default=1,option=num_threads)
    !$OMP parallel num_threads(n) private(i)
    !$OMP do
    do i=1,size(obj%stem)
        !if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%stem(i)%msh(name=trim(name)//"_stem"//trim(str(i)))
        !endif
    enddo
    !$OMP end do
    !$OMP end parallel

    !$OMP parallel num_threads(n) private(i)
    !$OMP do
    do i=1,size(obj%root)
        !if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%root(i)%msh(name=trim(name)//"_root"//trim(str(i)))
        !endif
    enddo
    !$OMP end do
    !$OMP end parallel

    !$OMP parallel num_threads(n) private(i)
    !$OMP do
    do i=1,size(obj%leaf)
        !if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%leaf(i)%msh(name=trim(name)//"_leaf"//trim(str(i)))
        !endif
    enddo
    !$OMP end do
    !$OMP end parallel

end subroutine
! ########################################

! ########################################
subroutine vtkGrape(obj,name,num_threads)
    class(Grape_),intent(inout) :: obj
    character(*),intent(in) :: name
    integer(int32),optional,intent(in) :: num_threads
    integer(int32) :: i, n

    n = input(default=1,option=num_threads)
    if(allocated(obj%stem) )then
        !$OMP parallel num_threads(n) private(i)
        !$OMP do
        do i=1,size(obj%stem)
            !if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then
                call obj%stem(i)%vtk(name=trim(name)//"_stem"//trim(str(i)))
            !endif
        enddo
        !$OMP end do
        !$OMP end parallel
    endif

    if(allocated(obj%root))then
        !$OMP parallel num_threads(n) private(i)
        !$OMP do
        do i=1,size(obj%root)
            !if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then
                call obj%root(i)%vtk(name=trim(name)//"_root"//trim(str(i)))
            !endif
        enddo
        !$OMP end do
        !$OMP end parallel
    endif

    if(allocated(obj%leaf))then
        !$OMP parallel num_threads(n) private(i)
        !$OMP do
        do i=1,size(obj%leaf)
            !if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then
                call obj%leaf(i)%vtk(name=trim(name)//"_leaf"//trim(str(i)))
            !endif
        enddo
        !$OMP end do
        !$OMP end parallel
    endif

end subroutine
! ########################################

! ########################################
subroutine jsonGrape(obj,name)
    class(Grape_),intent(inout) :: obj
    character(*),intent(in) :: name
    integer(int32) :: i,countnum
    type(IO_) :: f

    call f%open(trim(name)//".json")
    call f%write("{")
    countnum=0
    do i=1,size(obj%stem)
        if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then
            countnum=countnum+1
            call f%write('"'//"stem"//trim(str(i))//'":')
            call obj%stem(i)%femdomain%json(name=trim(name)//"_stem"//trim(str(i)),fh=f%fh,endl=.false.)
        endif
    enddo
    call f%write('"num_stem":'//str(countnum)//',' )

    countnum=0
    do i=1,size(obj%root)
        if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then
            countnum=countnum+1
            call f%write('"'//"root"//trim(str(i))//'":')
            call obj%root(i)%femdomain%json(name=trim(name)//"_root"//trim(str(i)),fh=f%fh,endl=.false.)
        endif
    enddo
    call f%write('"num_root":'//str(countnum)//',' )

    countnum=0
    do i=1,size(obj%leaf)
        if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then
            countnum=countnum+1
            call f%write('"'//"leaf"//trim(str(i))//'":')
            call obj%leaf(i)%femdomain%json(name=trim(name)//"_leaf"//trim(str(i)),fh=f%fh,endl=.false.)
        endif
    enddo
    call f%write('"num_leaf":'//str(countnum)//',' )
    call f%write('"return_Grape":0')
    call f%write("}")
    call f%close()
end subroutine
! ########################################

! ########################################
subroutine stlGrape(obj,name,num_threads)
    class(Grape_),intent(inout) :: obj
    character(*),intent(in) :: name
    integer(int32),optional,intent(in) :: num_threads
    integer(int32) :: i,n

    n = input(default=1,option=num_threads)
    !call execute_command_line("echo ' ' > "//trim(name)//".stl")
    !$OMP parallel num_threads(n) private(i)
    !$OMP do
    do i=1,size(obj%stem)
        if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%stem(i)%stl(name=trim(name)//"_stem"//trim(str(i)))
            !call execute_command_line("cat "//trim(name)//"_stem"//trim(str(i))//"_000001.stl >> "//trim(name)//".stl")
        endif
    enddo
    !$OMP end do
    !$OMP end parallel

    !$OMP parallel num_threads(n) private(i)
    !$OMP do
    do i=1,size(obj%root)
        if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%root(i)%stl(name=trim(name)//"_root"//trim(str(i)))
            !call execute_command_line("cat "//trim(name)//"_root"//trim(str(i))//"_000001.stl >> "//trim(name)//".stl")
        endif
    enddo
    !$OMP end do
    !$OMP end parallel

    !$OMP parallel num_threads(n) private(i)
    !$OMP do
    do i=1,size(obj%leaf)
        if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%leaf(i)%stl(name=trim(name)//"_leaf"//trim(str(i)))
            !call execute_command_line("cat "//trim(name)//"_leaf"//trim(str(i))//"_000001.stl >> "//trim(name)//".stl")
        endif
    enddo
    !$OMP end do
    !$OMP end parallel

end subroutine
! ########################################

! ########################################
subroutine moveGrape(obj,x,y,z)
    class(Grape_),intent(inout) :: obj
    real(real64),optional,intent(in) :: x,y,z
    integer(int32) :: i

    do i=1,size(obj%stem)
        if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%stem(i)%move(x=x,y=y,z=z)
        endif
    enddo

    do i=1,size(obj%root)
        if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%root(i)%move(x=x,y=y,z=z)
        endif
    enddo

    do i=1,size(obj%leaf)
        if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then
            call obj%leaf(i)%move(x=x,y=y,z=z)
        endif
    enddo

end subroutine
! ########################################

end module GrapeClass


MODULE icedyn
  USE phycst
  USE dom_oce
  USE ice
  USE icedyn_rhg
  USE icedyn_adv
  USE icedyn_rdgrft
  USE icecor
  USE icevar
  USE in_out_manager
  USE iom
  USE lib_mpp
  USE lib_fortran
  USE lbclnk
  USE timing
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: ice_dyn
  PUBLIC :: ice_dyn_init
  INTEGER :: nice_dyn
  INTEGER, PARAMETER :: np_dynFULL = 1
  INTEGER, PARAMETER :: np_dynRHGADV = 2
  INTEGER, PARAMETER :: np_dynADV = 3
  LOGICAL :: ln_dynFULL
  LOGICAL :: ln_dynRHGADV
  LOGICAL :: ln_dynADV
  REAL(KIND = wp) :: rn_uice
  REAL(KIND = wp) :: rn_vice
  CONTAINS
  SUBROUTINE ice_dyn(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jl
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpl) :: zhmax
    IF (ln_timing) CALL timing_start('icedyn')
    IF (kt == nit000 .AND. lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'ice_dyn: sea-ice dynamics'
      WRITE(numout, FMT = *) '~~~~~~~'
    END IF
    IF (ln_landfast) THEN
      !$ACC KERNELS
      tau_icebfr(:, :) = 0._wp
      !$ACC END KERNELS
      DO jl = 1, jpl
        WHERE (h_i(:, :, jl) > ht_n(:, :) * rn_gamma) tau_icebfr(:, :) = tau_icebfr(:, :) + a_i(:, :, jl) * rn_icebfr
      END DO
      IF (iom_use('tau_icebfr')) CALL iom_put('tau_icebfr', tau_icebfr)
    END IF
    !$ACC KERNELS
    zhmax(:, :, :) = h_i_b(:, :, :)
    !$ACC END KERNELS
    DO jl = 1, jpl
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zhmax(ji, jj, jl) = MAX(epsi20, MAXVAL(h_i_b(ji - 1 : ji + 1, jj - 1 : jj + 1, jl)))
        END DO
      END DO
    END DO
    CALL lbc_lnk(zhmax(:, :, :), 'T', 1.)
    SELECT CASE (nice_dyn)
    CASE (np_dynFULL)
      CALL ice_dyn_rhg(kt)
      CALL ice_dyn_adv(kt)
      CALL hbig(zhmax)
      CALL ice_dyn_rdgrft(kt)
      CALL ice_cor(kt, 1)
    CASE (np_dynRHGADV)
      CALL ice_dyn_rhg(kt)
      CALL ice_dyn_adv(kt)
      CALL Hpiling
    CASE (np_dynADV)
      !$ACC KERNELS
      u_ice(:, :) = rn_uice * umask(:, :, 1)
      v_ice(:, :) = rn_vice * vmask(:, :, 1)
      !$ACC END KERNELS
      CALL ice_dyn_adv(kt)
    END SELECT
    IF (ln_timing) CALL timing_stop('icedyn')
  END SUBROUTINE ice_dyn
  SUBROUTINE Hbig(phmax)
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN) :: phmax
    INTEGER :: ji, jj, jl
    REAL(KIND = wp) :: zh, zdv
    CALL ice_var_zapsmall
    !$ACC KERNELS
    DO jl = 1, jpl
      DO jj = 1, jpj
        DO ji = 1, jpi
          IF (v_i(ji, jj, jl) > 0._wp) THEN
            zh = v_i(ji, jj, jl) / a_i(ji, jj, jl)
            zdv = v_i(ji, jj, jl) - v_i_b(ji, jj, jl)
            IF ((zdv > 0.0 .AND. zh > phmax(ji, jj, jl) .AND. at_i_b(ji, jj) < 0.80) .OR. (zdv <= 0.0 .AND. zh > phmax(ji, jj, jl))) THEN
              a_i(ji, jj, jl) = v_i(ji, jj, jl) / MIN(phmax(ji, jj, jl), hi_max(jpl))
            END IF
          END IF
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    WHERE (a_ip(:, :, :) > a_i(:, :, :)) a_ip(:, :, :) = a_i(:, :, :)
  END SUBROUTINE Hbig
  SUBROUTINE Hpiling
    INTEGER :: jl
    CALL ice_var_zapsmall
    at_i(:, :) = SUM(a_i(:, :, :), dim = 3)
    DO jl = 1, jpl
      WHERE (at_i(:, :) > epsi20)
        a_i(:, :, jl) = a_i(:, :, jl) * (1._wp + MIN(rn_amax_2d(:, :) - at_i(:, :), 0._wp) / at_i(:, :))
      END WHERE
    END DO
  END SUBROUTINE Hpiling
  SUBROUTINE ice_dyn_init
    INTEGER :: ios, ioptio
    NAMELIST /namdyn/ ln_dynFULL, ln_dynRHGADV, ln_dynADV, rn_uice, rn_vice, rn_ishlat, ln_landfast, rn_gamma, rn_icebfr, rn_lfrelax
    REWIND(UNIT = numnam_ice_ref)
    READ(numnam_ice_ref, namdyn, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namdyn in reference namelist', lwp)
    REWIND(UNIT = numnam_ice_cfg)
    READ(numnam_ice_cfg, namdyn, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namdyn in configuration namelist', lwp)
    IF (lwm) WRITE(numoni, namdyn)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'ice_dyn_init: ice parameters for ice dynamics '
      WRITE(numout, FMT = *) '~~~~~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namdyn:'
      WRITE(numout, FMT = *) '      Full ice dynamics      (rhg + adv + ridge/raft + corr)  ln_dynFULL   = ', ln_dynFULL
      WRITE(numout, FMT = *) '      No ridge/raft & No cor (rhg + adv)                      ln_dynRHGADV = ', ln_dynRHGADV
      WRITE(numout, FMT = *) '      Advection only         (rn_uvice + adv)                 ln_dynADV    = ', ln_dynADV
      WRITE(numout, FMT = *) '         with prescribed velocity given by   (u,v)_ice = (rn_uice,rn_vice) = (', rn_uice, ',', rn_vice, ')'
      WRITE(numout, FMT = *) '      lateral boundary condition for sea ice dynamics         rn_ishlat    = ', rn_ishlat
      WRITE(numout, FMT = *) '      Landfast: param (T or F)                                ln_landfast  = ', ln_landfast
      WRITE(numout, FMT = *) '         fraction of ocean depth that ice must reach          rn_gamma     = ', rn_gamma
      WRITE(numout, FMT = *) '         maximum bottom stress per unit area of contact       rn_icebfr    = ', rn_icebfr
      WRITE(numout, FMT = *) '         relax time scale (s-1) to reach static friction      rn_lfrelax   = ', rn_lfrelax
      WRITE(numout, FMT = *)
    END IF
    ioptio = 0
    IF (ln_dynfull) THEN
      ioptio = ioptio + 1
      nice_dyn = np_dynfull
    END IF
    IF (ln_dynrhgadv) THEN
      ioptio = ioptio + 1
      nice_dyn = np_dynrhgadv
    END IF
    IF (ln_dynadv) THEN
      ioptio = ioptio + 1
      nice_dyn = np_dynadv
    END IF
    IF (ioptio /= 1) CALL ctl_stop('ice_dyn_init: one and only one ice dynamics option has to be defined ')
    IF (rn_ishlat == 0.) THEN
      IF (lwp) WRITE(numout, FMT = *) '   ===>>>   ice lateral  free-slip'
    ELSE IF (rn_ishlat == 2.) THEN
      IF (lwp) WRITE(numout, FMT = *) '   ===>>>   ice lateral  no-slip'
    ELSE IF (0. < rn_ishlat .AND. rn_ishlat < 2.) THEN
      IF (lwp) WRITE(numout, FMT = *) '   ===>>>   ice lateral  partial-slip'
    ELSE IF (2. < rn_ishlat) THEN
      IF (lwp) WRITE(numout, FMT = *) '   ===>>>   ice lateral  strong-slip'
    END IF
    IF (.NOT. ln_landfast) tau_icebfr(:, :) = 0._wp
    CALL ice_dyn_rdgrft_init
    CALL ice_dyn_rhg_init
    CALL ice_dyn_adv_init
  END SUBROUTINE ice_dyn_init
END MODULE icedyn


! This program is an example which illustrates how to read
! earthquake simulator input files.

program input_example

implicit none

integer :: section
integer :: vertex
integer :: element

! Container parameters

integer, parameter :: ctr_recl = 2504   ! Maximum record length

! Geometry summary record

integer, parameter :: gsum_kind = 200   ! Kind for geometry file, summary record
integer :: gsum_n_section               ! Total number of fault sections
integer :: gsum_n_vertex                ! Total number of vertices
integer :: gsum_n_triangle              ! Total number of triangles
integer :: gsum_n_rectangle             ! Total number of rectangles
real(8) :: gsum_lat_lo                  ! Lowest latitude
real(8) :: gsum_lat_hi                  ! Highest latitude
real(8) :: gsum_lon_lo                  ! Lowest longitude
real(8) :: gsum_lon_hi                  ! Highest longitude
real(8) :: gsum_depth_lo                ! Lowest depth
real(8) :: gsum_depth_hi                ! Highest depth

! Geometry section record

integer, parameter :: gsec_kind = 201   ! Kind for geometry file, section information record
integer :: gsec_sid                     ! Section identification number
character(100) :: gsec_name             ! Section name
integer :: gsec_n_vertex                ! Number of vertices within section
integer :: gsec_n_triangle              ! Number of triangles within section
integer :: gsec_n_rectangle             ! Number of rectangles within section
real(8) :: gsec_lat_lo                  ! Lowest latitude within section
real(8) :: gsec_lat_hi                  ! Highest latitude within section
real(8) :: gsec_lon_lo                  ! Lowest longitude within section
real(8) :: gsec_lon_hi                  ! Highest longitude within section
real(8) :: gsec_depth_lo                ! Lowest depth within section
real(8) :: gsec_depth_hi                ! Highest depth within section
real(8) :: gsec_das_lo                  ! Lowest distance along strike within section
real(8) :: gsec_das_hi                  ! Highest distance along strike within section
integer :: gsec_fault_id                ! Fault identification number

! Geometry vertex record

integer, parameter :: gver_kind = 202   ! Kind for geometry file, vertex record
integer :: gver_index                   ! Vertex index number (counts beginning with 1)
real(8) :: gver_lat                     ! Latitude (degrees, positive north)
real(8) :: gver_lon                     ! Longitude (degrees, positive east)
real(8) :: gver_depth                   ! Depth (meters, negative underground)
real(8) :: gver_das                     ! Distance along strike (meters)
integer :: gver_trace_flag              ! On-trace flag (0=not on trace, 1=on trace, 2=initial point of trace, 3=final point of trace)

! Geometry triangle record

integer, parameter :: gtri_kind = 203   ! Kind for geometry file, triangle record
integer :: gtri_index                   ! Element index number (counts beginning with 1)
integer :: gtri_vertex_1                ! Index number for vertex #1
integer :: gtri_vertex_2                ! Index number for vertex #2
integer :: gtri_vertex_3                ! Index number for vertex #3
real(8) :: gtri_rake                    ! Rake angle (degrees)
real(8) :: gtri_slip_rate               ! Slip rate (meters/second)
real(8) :: gtri_aseis_factor            ! Aseismicity factor
real(8) :: gtri_strike                  ! Strike angle (degrees)
real(8) :: gtri_dip                     ! Dip angle (degrees)

! Geometry rectangle record

integer, parameter :: grec_kind = 204   ! Kind for geometry file, rectangle record
integer :: grec_index                   ! Element index number (counts beginning with 1)
integer :: grec_vertex_1                ! Index number for vertex #1
integer :: grec_vertex_2                ! Index number for vertex #2
integer :: grec_vertex_3                ! Index number for vertex #3
integer :: grec_vertex_4                ! Index number for vertex #4
real(8) :: grec_rake                    ! Rake angle (degrees)
real(8) :: grec_slip_rate               ! Slip rate (meters/second)
real(8) :: grec_aseis_factor            ! Aseismicity factor
real(8) :: grec_strike                  ! Strike angle (degrees)
real(8) :: grec_dip                     ! Dip angle (degrees)
integer :: grec_perfect_flag            ! Perfect rectangle flag (0=not perfect, 1=perfect)

! Friction summary record

integer, parameter :: fsum_kind = 200   ! Kind for friction file, summary record
integer :: fsum_n_element               ! Total number of elements
integer :: fsum_elastic_flag            ! Elastic parameters flag (1=included, 0=not included)
integer :: fsum_strength_flag           ! Fault strength flag (1=included, 0=not included)
integer :: fsum_rate_state_flag         ! Rate-state initial state flag (1=included, 0=not included)

! Friction elastic parameter record

integer, parameter :: felp_kind = 201   ! Kind for friction file, elastic parameter record
real(8) :: felp_lame_lambda             ! Lame modulus lambda (Pascal)
real(8) :: felp_lame_mu                 ! Lame modulus mu, also known as the shear modulus (Pascal)

! Friction fault strength record

integer, parameter :: fstr_kind = 202   ! Kind for friction file, fault strength record
integer :: fstr_index                   ! Element index number
real(8) :: fstr_static_strength         ! Static yield strength (Pascal)
real(8) :: fstr_dynamic_strength        ! Dynamic sliding strength (Pascal)

! Friction rate-state parameter record

integer, parameter :: frsp_kind = 203   ! Kind for friction file, rate-state parameter record
integer :: frsp_index                   ! Element index number
real(8) :: frsp_A                       ! Rate-state parameter A
real(8) :: frsp_B                       ! Rate-state parameter B
real(8) :: frsp_L                       ! Rate-state critical distance L (meters)
real(8) :: frsp_f0                      ! Rate-state friction coefficient
real(8) :: frsp_V0                      ! Rate-state reference velocity (meters/second)

! Initial condition summary record

integer, parameter :: csum_kind = 200   ! Kind for initial condition file, summary record
integer :: csum_n_element               ! Total number of elements
integer :: csum_stress_flag             ! Initial stress flag (1=included, 0=not included)
integer :: csum_state_flag              ! Initial state flag (1=included, 0=not included)

! Initial condition stress record

integer, parameter :: csts_kind = 201   ! Kind for initial condition file, initial stress record
integer :: csts_index                   ! Element index number
real(8) :: csts_shear_stress            ! Initial shear stress (Pascal)
real(8) :: csts_normal_stress           ! Initial normal stress (Pascal)

! Initial condition state record

integer, parameter :: crst_kind = 202   ! Kind for initial condition file, initial state record
integer :: crst_index                   ! Element index number
real(8) :: crst_rs_theta                ! Initial rate-state variable theta (seconds)

! In this simple example we will just write out a summary of the input.
! A real simulator would use the input to build up a data structure in memory.
! This is our output file.

open(10, file='input_example_result.dat', status='replace', recl=ctr_recl)

! Open geometry file, and check the signature.
! Note we use spec level 2, for file format version 0.4.

open(7, file='NCA_Ward_Geometry.dat', status='old', recl=ctr_recl)
call check_signature (7, 'EQSim_Input_Geometry_2', 2)

! Read the fault geometry summary record

call find_record (7, gsum_kind)
read(7,*) gsum_n_section, gsum_n_vertex, gsum_n_triangle, gsum_n_rectangle,    &
          gsum_lat_lo, gsum_lat_hi, gsum_lon_lo, gsum_lon_hi, gsum_depth_lo, gsum_depth_hi

if (gsum_n_triangle .ne. 0) then
    write(6,*) 'Geometry file contains triangles, but we only support rectangles in this example.'
    stop
endif

write(10,*) 'Geometry summary, sections=', gsum_n_section, ', vertices=', gsum_n_vertex, ', rectangles=', gsum_n_rectangle

! Open friction file, and check the signature

open(8, file='NCA_Ward_Friction.dat', status='old', recl=ctr_recl)
call check_signature (8, 'EQSim_Input_Friction_2', 1)

! Read the friction summary record

call find_record (8, fsum_kind)
read(8,*) fsum_n_element, fsum_elastic_flag, fsum_strength_flag, fsum_rate_state_flag

if (fsum_elastic_flag .eq. 0) then
    write(6,*) 'Friction file does not contain elastic parameters, but we require it in this example.'
    stop
endif

if (fsum_strength_flag .eq. 0) then
    write(6,*) 'Friction file does not contain fault strangth, but we require it in this example.'
    stop
endif

if (fsum_n_element .ne. gsum_n_triangle + gsum_n_rectangle) then
    write(6,*) 'Friction file element count does not match geometry file.'
    stop
endif

write(10,*) 'Friction summary, elements=', fsum_n_element

! Read the elastic parameter record from the friction file

call find_record (8, felp_kind)
read(8,*) felp_lame_lambda, felp_lame_mu

write(10,*) 'Elastic parameters, lame lambda=', felp_lame_lambda, 'lame mu=', felp_lame_mu

! Open initial condition file, and check the signature

open(9, file='NCA_Ward_Condition.dat', status='old', recl=ctr_recl)
call check_signature (9, 'EQSim_Input_Condition_2', 1)

! Read the initial condition summary record

call find_record (9, csum_kind)
read(9,*) csum_n_element, csum_stress_flag, csum_state_flag

if (csum_stress_flag .eq. 0) then
    write(6,*) 'Initial condition file does not contain stress, but we require it in this example.'
    stop
endif

if (csum_n_element .ne. gsum_n_triangle + gsum_n_rectangle) then
    write(6,*) 'Initial condition file element count does not match geometry file.'
    stop
endif

write(10,*) 'Initial condition summary, elements=', fsum_n_element

! Loop over all fault sections

do section = 1,gsum_n_section

    ! Read the section information record from the geometry file

    call find_record (7, gsec_kind)
    read(7,*) gsec_sid, gsec_name, gsec_n_vertex, gsec_n_triangle, gsec_n_rectangle,    &
              gsec_lat_lo, gsec_lat_hi, gsec_lon_lo, gsec_lon_hi,                       &
              gsec_depth_lo, gsec_depth_hi, gsec_das_lo, gsec_das_hi, gsec_fault_id

    write(10,*) 'Fault section, id=', gsec_sid, ', name=', gsec_name(1:len_trim(gsec_name)),    &
                ', vertices=', gsec_n_vertex, ', rectangles=', gsec_n_rectangle

    ! Loop over all vertices within the section

    do vertex = 1,gsec_n_vertex

        ! Read the vertex record from the geometry file

        call find_record (7, gver_kind)
        read(7,*) gver_index, gver_lat, gver_lon, gver_depth, gver_das, gver_trace_flag

        write(10,*) 'Vertex, index=', gver_index, ', depth=', gver_depth, ', das=', gver_das

    enddo

    ! Loop over all elements within the section

    do element = 1,gsec_n_rectangle

        ! Read the element record from the geometry file, which is a rectangle because we checked above there are no triangles

        call find_record (7, grec_kind)
        read(7,*) grec_index, grec_vertex_1, grec_vertex_2, grec_vertex_3, grec_vertex_4,   &
                  grec_rake, grec_slip_rate, grec_aseis_factor,                             &
                  grec_strike, grec_dip, grec_perfect_flag

        ! Read the fault strength record from the friction file

        call find_record (8, fstr_kind)
        read(8,*) fstr_index, fstr_static_strength, fstr_dynamic_strength

        ! Read the initial stress record from the initial condition file

        call find_record (9, csts_kind)
        read(9,*) csts_index, csts_shear_stress, csts_normal_stress

        write(10,*) 'Rectangle, index=', grec_index, ', rake=', grec_rake,          &
                    ', strike=', grec_strike,                                       &
                    ', dip=', grec_dip,                                             &
                    ', slip rate=', grec_slip_rate,                                 &
                    ', strength=', fstr_static_strength - fstr_dynamic_strength,    &
                    ', shear stress=', csts_shear_stress

    enddo

enddo

stop
end program input_example

! This subroutine scans a file until it finds a record
! of the desired kind.  If end-of-file is encountered,
! write an error message and terminate the program.

subroutine find_record (file_unit, record_kind)

implicit none
integer :: file_unit                    ! Fortran unit number
integer :: record_kind                  ! Kind of record to search for

integer :: current_kind                 ! Kind of the current line in the file
integer, parameter :: eof_kind = 999    ! Kind for end-of-file record

do
    read(file_unit,'(i3)',advance='no') current_kind    ! Non-advancing I/O reads just the 3-digit record kind

    if (current_kind .eq. record_kind) exit     ! Found our kind of record, stop searching

    if (current_kind .eq. eof_kind) then        ! Found end-of-file, it's an error
        write(6,*) 'Found end-of-file when searching for record kind=', record_kind, ', in unit=', file_unit
        stop
    endif

    read(file_unit,*)           ! Skip this record
enddo

return
end subroutine find_record

! This subroutine reads the first record of a file, and
! checks that it is a signature record with the desired
! signature keyword and specification level.

subroutine check_signature (file_unit, desired_keyword, desired_spec_level)

implicit none
integer :: file_unit                ! Fortran unit number
character(*) :: desired_keyword     ! Expected signature keyword
integer :: desired_spec_level       ! Expected specification level

integer :: current_kind             ! Kind of the current line in the file

! Signature record

integer, parameter :: sig_kind = 101
character(100) :: sig_keyword
integer :: sig_spec_level

! Read the kind of the first record, and check it

read(file_unit,'(i3)',advance='no') current_kind    ! Non-advancing I/O reads just the 3-digit record kind

if (current_kind .ne. sig_kind) then
    write(6,*) 'First line of file is not a signature record, in unit=', file_unit
    stop
endif

! Read the contents of the signature record

read(file_unit,*) sig_keyword, sig_spec_level

! Check signature keyword

if (sig_keyword .ne. desired_keyword) then
    write(6,*) 'Incorrect file signature, in unit=', file_unit
    stop
endif

! Check specification level

if (sig_spec_level < desired_spec_level) then
    write(6,*) 'Incompatible file specification level, in unit=', file_unit
    stop
endif

return
end subroutine check_signature