C
C	$Id: csdelnod.f,v 1.5 2008-07-27 03:10:06 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSDELNOD (K, N,X,Y,Z,LIST,LPTR,LEND,LNEW,LWK,
     .                   IWK, IER)
      INTEGER K, N, LIST(*), LPTR(*), LEND(*), LNEW, LWK,
     .        IWK(2,*), IER
      DOUBLE PRECISION X(*), Y(*), Z(*)
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   11/30/99
C
C   This subroutine deletes node K (along with all arcs
C incident on node K) from a triangulation of N nodes on the
C unit sphere, and inserts arcs as necessary to produce a
C triangulation of the remaining N-1 nodes.  If a Delaunay
C triangulation is input, a Delaunay triangulation will
C result, and thus, CSDELNOD reverses the effect of a call to
C Subroutine CSADDNOD.
C
C
C On input:
C
C       K = Index (for X, Y, and Z) of the node to be
C           deleted.  1 .LE. K .LE. N.
C
C K is not altered by this routine.
C
C       N = Number of nodes in the triangulation on input.
C           N .GE. 4.  Note that N will be decremented
C           following the deletion.
C
C       X,Y,Z = Arrays of length N containing the Cartesian
C               coordinates of the nodes in the triangula-
C               tion.
C
C       LIST,LPTR,LEND,LNEW = Data structure defining the
C                             triangulation.  Refer to Sub-
C                             routine CSTRMESH.
C
C       LWK = Number of columns reserved for IWK.  LWK must
C             be at least NNB-3, where NNB is the number of
C             neighbors of node K, including an extra
C             pseudo-node if K is a boundary node.
C
C       IWK = Integer work array dimensioned 2 by LWK (or
C             array of length .GE. 2*LWK).
C
C On output:
C
C       N = Number of nodes in the triangulation on output.
C           The input value is decremented unless 1 .LE. IER
C           .LE. 4.
C
C       X,Y,Z = Updated arrays containing nodal coordinates
C               (with elements K+1,...,N+1 shifted up one
C               position, thus overwriting element K) unless
C               1 .LE. IER .LE. 4.
C
C       LIST,LPTR,LEND,LNEW = Updated triangulation data
C                             structure reflecting the dele-
C                             tion unless 1 .LE. IER .LE. 4.
C                             Note that the data structure
C                             may have been altered if IER >
C                             3.
C
C       LWK = Number of IWK columns required unless IER = 1
C             or IER = 3.
C
C       IWK = Indexes of the endpoints of the new arcs added
C             unless LWK = 0 or 1 .LE. IER .LE. 4.  (Arcs
C             are associated with columns, or pairs of
C             adjacent elements if IWK is declared as a
C             singly-subscripted array.)
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if K or N is outside its valid range
C                     or LWK < 0 on input.
C             IER = 2 if more space is required in IWK.
C                     Refer to LWK.
C             IER = 3 if the triangulation data structure is
C                     invalid on input.
C             IER = 4 if K indexes an interior node with
C                     four or more neighbors, none of which
C                     can be swapped out due to collineari-
C                     ty, and K cannot therefore be deleted.
C             IER = 5 if an error flag (other than IER = 1)
C                     was returned by CSOPTIM.  An error
C                     message is written to the standard
C                     output unit in this case.
C             IER = 6 if error flag 1 was returned by CSOPTIM.
C                     This is not necessarily an error, but
C                     the arcs may not be optimal.
C
C   Note that the deletion may result in all remaining nodes
C being collinear.  This situation is not flagged.
C
C Modules required by CSDELNOD:  CSDELNB, CSLEFT, CSLSTPTR, CSNBCNT,
C                                CSOPTIM, CSSWAP, CSSWPTST
C
C Intrinsic function called by CSDELNOD:  ABS
C
C***********************************************************
C
      INTEGER CSLSTPTR, CSNBCNT
      INTEGER I, IERR, IWL, J, LNW, LP, LP21, LPF, LPH, LPL,
     .        LPL2, LPN, LWKL, N1, N2, NFRST, NIT, NL, NN,
     .        NNB, NR
      LOGICAL CSLEFT
      LOGICAL BDRY
      DOUBLE PRECISION X1, X2, XL, XR, Y1, Y2, YL, YR, Z1,
     .                 Z2, ZL, ZR
C
C Local parameters:
C
C BDRY =    Logical variable with value TRUE iff N1 is a
C             boundary node
C I,J =     DO-loop indexes
C IERR =    Error flag returned by CSOPTIM
C IWL =     Number of IWK columns containing arcs
C LNW =     Local copy of LNEW
C LP =      LIST pointer
C LP21 =    LIST pointer returned by CSSWAP
C LPF,LPL = Pointers to the first and last neighbors of N1
C LPH =     Pointer (or flag) returned by CSDELNB
C LPL2 =    Pointer to the last neighbor of N2
C LPN =     Pointer to a neighbor of N1
C LWKL =    Input value of LWK
C N1 =      Local copy of K
C N2 =      Neighbor of N1
C NFRST =   First neighbor of N1:  LIST(LPF)
C NIT =     Number of iterations in CSOPTIM
C NR,NL =   Neighbors of N1 preceding (to the right of) and
C             following (to the left of) N2, respectively
C NN =      Number of nodes in the triangulation
C NNB =     Number of neighbors of N1 (including a pseudo-
C             node representing the boundary if N1 is a
C             boundary node)
C X1,Y1,Z1 = Coordinates of N1
C X2,Y2,Z2 = Coordinates of N2
C XL,YL,ZL = Coordinates of NL
C XR,YR,ZR = Coordinates of NR
C
C
C Set N1 to K and NNB to the number of neighbors of N1 (plus
C   one if N1 is a boundary node), and test for errors.  LPF
C   and LPL are LIST indexes of the first and last neighbors
C   of N1, IWL is the number of IWK columns containing arcs,
C   and BDRY is TRUE iff N1 is a boundary node.
C
      N1 = K
      NN = N
      IF (N1 .LT. 1  .OR.  N1 .GT. NN  .OR.  NN .LT. 4  .OR.
     .    LWK .LT. 0) GO TO 21
      LPL = LEND(N1)
      LPF = LPTR(LPL)
      NNB = CSNBCNT(LPL,LPTR)
      BDRY = LIST(LPL) .LT. 0
      IF (BDRY) NNB = NNB + 1
      IF (NNB .LT. 3) GO TO 23
      LWKL = LWK
      LWK = NNB - 3
      IF (LWKL .LT. LWK) GO TO 22
      IWL = 0
      IF (NNB .EQ. 3) GO TO 3
C
C Initialize for loop on arcs N1-N2 for neighbors N2 of N1,
C   beginning with the second neighbor.  NR and NL are the
C   neighbors preceding and following N2, respectively, and
C   LP indexes NL.  The loop is exited when all possible
C   swaps have been applied to arcs incident on N1.
C
      X1 = X(N1)
      Y1 = Y(N1)
      Z1 = Z(N1)
      NFRST = LIST(LPF)
      NR = NFRST
      XR = X(NR)
      YR = Y(NR)
      ZR = Z(NR)
      LP = LPTR(LPF)
      N2 = LIST(LP)
      X2 = X(N2)
      Y2 = Y(N2)
      Z2 = Z(N2)
      LP = LPTR(LP)
C
C Top of loop:  set NL to the neighbor following N2.
C
    1 NL = ABS(LIST(LP))
      IF (NL .EQ. NFRST  .AND.  BDRY) GO TO 3
      XL = X(NL)
      YL = Y(NL)
      ZL = Z(NL)
C
C   Test for a convex quadrilateral.  To avoid an incorrect
C     test caused by collinearity, use the fact that if N1
C     is a boundary node, then N1 CSLEFT NR->NL and if N2 is
C     a boundary node, then N2 CSLEFT NL->NR.
C
      LPL2 = LEND(N2)
      IF ( .NOT. ((BDRY  .OR.  CSLEFT(XR,YR,ZR,XL,YL,ZL,X1,Y1,
     .      Z1))  .AND.  (LIST(LPL2) .LT. 0  .OR.
     .      CSLEFT(XL,YL,ZL,XR,YR,ZR,X2,Y2,Z2))) ) THEN
C
C   Nonconvex quadrilateral -- no swap is possible.
C
        NR = N2
        XR = X2
        YR = Y2
        ZR = Z2
        GO TO 2
      ENDIF
C
C   The quadrilateral defined by adjacent triangles
C     (N1,N2,NL) and (N2,N1,NR) is convex.  Swap in
C     NL-NR and store it in IWK unless NL and NR are
C     already adjacent, in which case the swap is not
C     possible.  Indexes larger than N1 must be decremented
C     since N1 will be deleted from X, Y, and Z.
C
      CALL CSSWAP (NL,NR,N1,N2, LIST,LPTR,LEND, LP21)
      IF (LP21 .EQ. 0) THEN
        NR = N2
        XR = X2
        YR = Y2
        ZR = Z2
        GO TO 2
      ENDIF
      IWL = IWL + 1
      IF (NL .LE. N1) THEN
        IWK(1,IWL) = NL
      ELSE
        IWK(1,IWL) = NL - 1
      ENDIF
      IF (NR .LE. N1) THEN
        IWK(2,IWL) = NR
      ELSE
        IWK(2,IWL) = NR - 1
      ENDIF
C
C   Recompute the LIST indexes and NFRST, and decrement NNB.
C
      LPL = LEND(N1)
      NNB = NNB - 1
      IF (NNB .EQ. 3) GO TO 3
      LPF = LPTR(LPL)
      NFRST = LIST(LPF)
      LP = CSLSTPTR(LPL,NL,LIST,LPTR)
      IF (NR .EQ. NFRST) GO TO 2
C
C   NR is not the first neighbor of N1.
C     Back up and test N1-NR for a swap again:  Set N2 to
C     NR and NR to the previous neighbor of N1 -- the
C     neighbor of NR which follows N1.  LP21 points to NL
C     as a neighbor of NR.
C
      N2 = NR
      X2 = XR
      Y2 = YR
      Z2 = ZR
      LP21 = LPTR(LP21)
      LP21 = LPTR(LP21)
      NR = ABS(LIST(LP21))
      XR = X(NR)
      YR = Y(NR)
      ZR = Z(NR)
      GO TO 1
C
C   Bottom of loop -- test for termination of loop.
C
    2 IF (N2 .EQ. NFRST) GO TO 3
      N2 = NL
      X2 = XL
      Y2 = YL
      Z2 = ZL
      LP = LPTR(LP)
      GO TO 1
C
C Delete N1 and all its incident arcs.  If N1 is an interior
C   node and either NNB > 3 or NNB = 3 and N2 CSLEFT NR->NL,
C   then N1 must be separated from its neighbors by a plane
C   containing the origin -- its removal reverses the effect
C   of a call to CSCOVSPH, and all its neighbors become
C   boundary nodes.  This is achieved by treating it as if
C   it were a boundary node (setting BDRY to TRUE, changing
C   a sign in LIST, and incrementing NNB).
C
    3 IF (.NOT. BDRY) THEN
        IF (NNB .GT. 3) THEN
          BDRY = .TRUE.
        ELSE
          LPF = LPTR(LPL)
          NR = LIST(LPF)
          LP = LPTR(LPF)
          N2 = LIST(LP)
          NL = LIST(LPL)
          BDRY = CSLEFT(X(NR),Y(NR),Z(NR),X(NL),Y(NL),Z(NL),
     .                X(N2),Y(N2),Z(N2))
        ENDIF
        IF (BDRY) THEN
C
C   IF a boundary node already exists, then N1 and its
C     neighbors cannot be converted to boundary nodes.
C     (They must be collinear.)  This is a problem if
C     NNB > 3.
C
          DO 4 I = 1,NN
            IF (LIST(LEND(I)) .LT. 0) THEN
              BDRY = .FALSE.
              GO TO 5
            ENDIF
    4       CONTINUE
          LIST(LPL) = -LIST(LPL)
          NNB = NNB + 1
        ENDIF
      ENDIF
    5 IF (.NOT. BDRY  .AND.  NNB .GT. 3) GO TO 24
C
C Initialize for loop on neighbors.  LPL points to the last
C   neighbor of N1.  LNEW is stored in local variable LNW.
C
      LP = LPL
      LNW = LNEW
C
C Loop on neighbors N2 of N1, beginning with the first.
C
    6 LP = LPTR(LP)
        N2 = ABS(LIST(LP))
        CALL CSDELNB (N2,N1,N, LIST,LPTR,LEND,LNW, LPH)
        IF (LPH .LT. 0) GO TO 23
C
C   LP and LPL may require alteration.
C
        IF (LPL .EQ. LNW) LPL = LPH
        IF (LP .EQ. LNW) LP = LPH
        IF (LP .NE. LPL) GO TO 6
C
C Delete N1 from X, Y, Z, and LEND, and remove its adjacency
C   list from LIST and LPTR.  LIST entries (nodal indexes)
C   which are larger than N1 must be decremented.
C
      NN = NN - 1
      IF (N1 .GT. NN) GO TO 9
      DO 7 I = N1,NN
        X(I) = X(I+1)
        Y(I) = Y(I+1)
        Z(I) = Z(I+1)
        LEND(I) = LEND(I+1)
    7   CONTINUE
C
      DO 8 I = 1,LNW-1
        IF (LIST(I) .GT. N1) LIST(I) = LIST(I) - 1
        IF (LIST(I) .LT. -N1) LIST(I) = LIST(I) + 1
    8   CONTINUE
C
C   For LPN = first to last neighbors of N1, delete the
C     preceding neighbor (indexed by LP).
C
C   Each empty LIST,LPTR location LP is filled in with the
C     values at LNW-1, and LNW is decremented.  All pointers
C     (including those in LPTR and LEND) with value LNW-1
C     must be changed to LP.
C
C  LPL points to the last neighbor of N1.
C
    9 IF (BDRY) NNB = NNB - 1
      LPN = LPL
      DO 13 J = 1,NNB
        LNW = LNW - 1
        LP = LPN
        LPN = LPTR(LP)
        LIST(LP) = LIST(LNW)
        LPTR(LP) = LPTR(LNW)
        IF (LPTR(LPN) .EQ. LNW) LPTR(LPN) = LP
        IF (LPN .EQ. LNW) LPN = LP
        DO 10 I = NN,1,-1
          IF (LEND(I) .EQ. LNW) THEN
            LEND(I) = LP
            GO TO 11
          ENDIF
   10     CONTINUE
C
   11   DO 12 I = LNW-1,1,-1
          IF (LPTR(I) .EQ. LNW) LPTR(I) = LP
   12     CONTINUE
   13   CONTINUE
C
C Update N and LNEW, and optimize the patch of triangles
C   containing K (on input) by applying swaps to the arcs
C   in IWK.
C
      N = NN
      LNEW = LNW
      IF (IWL .GT. 0) THEN
        NIT = 4*IWL
        CALL CSOPTIM (X,Y,Z,IWL, LIST,LPTR,LEND,NIT,IWK, IERR)
        IF (IERR .NE. 0  .AND.  IERR .NE. 1) GO TO 25
        IF (IERR .EQ. 1) GO TO 26
      ENDIF
C
C Successful termination.
C
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   21 IER = 1
      RETURN
C
C Insufficient space reserved for IWK.
C
   22 IER = 2
      RETURN
C
C Invalid triangulation data structure.  NNB < 3 on input or
C   N2 is a neighbor of N1 but N1 is not a neighbor of N2.
C
   23 IER = 3
      RETURN
C
C N1 is interior but NNB could not be reduced to 3.
C
   24 IER = 4
      RETURN
C
C Error flag (other than 1) returned by CSOPTIM.
C
   25 IER = 5
      WRITE (*,100) NIT, IERR
  100 FORMAT (//5X,'*** Error in CSOPTIM (called from ',
     .        'CSDELNOD):  NIT = ',I4,', IER = ',I1,' ***'/)
      RETURN
C
C Error flag 1 returned by CSOPTIM.
C
   26 IER = 6
      RETURN
      END


      SUBROUTINE TRID (MR,A,B,C,Y,D)
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,Y(1)       ,
     1                D(1)
      M = MR
      MM1 = M-1
      Z = 1./B(1)
      D(1) = C(1)*Z
      Y(1) = Y(1)*Z
      DO 101 I=2,MM1
         Z = 1./(B(I)-A(I)*D(I-1))
         D(I) = C(I)*Z
         Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  101 CONTINUE
      Z = B(M)-A(M)*D(MM1)
      IF (Z .NE. 0.) GO TO 102
      Y(M) = 0.
      GO TO 103
  102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  103 CONTINUE
      DO 104 IP=1,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)
  104 CONTINUE
      RETURN
      END


!
!     (c) 2019-2020 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
!     contract # NRC-HQ-60-17-C-0007
!
program main
  !! Test the definition of a block-structured problem discretization
  use assertions_interface, only : assert, assertions
  use problem_discretization_interface, only :  problem_discretization
  use cartesian_grid_interface, only : cartesian_grid
  use kind_parameters, only : r8k
  implicit none

  type(problem_discretization) global_grid
    !! encapsulate the global grid structure
  type(cartesian_grid) prototype
    !! pass the cartesian_grid type
  integer, parameter :: space_dimensions=3
    !! maximum number of spatial dimensions
  integer, parameter :: lo_bound=1, up_bound=2
    !! array index values for defining lower & upper bounds for 1D spatial interval
  real(r8k), parameter :: global_domain(*,*) = reshape([0.,120., 0.,2.5, 0.,2.5],[up_bound,space_dimensions])
    !! overall rectangular domain boundaries
  integer, parameter :: num_structured_grids(*) = [240,5,5]
    !! number of blocks in each coordinate direction

  call global_grid%partition( num_structured_grids, prototype )
    !! partition the block-structured grid into blocks with connectivity implied by the supplied shape of the 3D array of blocks

  associate( my_blocks => global_grid%my_blocks() )

    block
      integer ijk(space_dimensions)
        !! indicial coordinates of this block
      real(r8k), allocatable, dimension(:,:,:) :: x, y, z
        !! coordinates of grid vertex locations
      real(r8k) block(lo_bound:up_bound,space_dimensions)
      integer m,n
      integer, parameter :: nx=11,ny=11,nz=11
        !! resolution within blocks

    !do concurrent( n = my_blocks(1) : my_blocks(2)) TODO: make concurrent after Intel supports co_sum
      do n = my_blocks(1) , my_blocks(2)
        ijk = global_grid%block_indicial_coordinates(n)

        do concurrent(m=1:space_dimensions)
          associate( block_width_m => (global_domain(up_bound,m) - global_domain(lo_bound,m))/num_structured_grids(m))
            block(:,m) = [ ijk(m)-1, ijk(m) ]*block_width_m
          end associate
        end do

        x = evenly_spaced_points(  block, [nx,ny,nz], direction=1 )
        y = evenly_spaced_points(  block, [nx,ny,nz], direction=2 )
        z = evenly_spaced_points(  block, [nx,ny,nz], direction=3 )

        call global_grid%set_vertices(x,y,z,block_identifier=n)
      end do
    end block
  end associate

  if (assertions) &
    call assert(load_balanced(global_grid%block_load(),product(num_structured_grids)),"test_problem_discretization: load balanced")

  sync all
  if (this_image()==1) print *,"Test passed."

contains

  pure function load_balanced(my_load, total_load) result(block_distribution)
    integer, intent(in) :: my_load, total_load
    logical :: block_distribution
    block_distribution = ( my_load == total_load/num_images() + merge(1,0,this_image()<=mod(total_load,num_images())) )
  end function

  pure function evenly_spaced_points( boundaries, resolution, direction ) result(grid_nodes)
    !! Define grid point coordinates with uniform spacing in the chosen block
    real(r8k), intent(in) :: boundaries(:,:)
      !! block boundaries of each coordinate direction
    integer, intent(in) :: resolution(:)
      !! number of grid points in each direction
    integer, intent(in) :: direction
      !! coordinate direction to define
    real(r8k), allocatable :: grid_nodes(:,:,:)
      !! grid node locations and spacing in each coordination direction
    real(r8k) dx(space_dimensions)

    integer ix,iy,iz

    allocate(grid_nodes(resolution(1),resolution(2),resolution(3)))

    dx = ( boundaries(up_bound,:) - boundaries(lo_bound,:) ) / resolution(:)

    associate( nx=>resolution(1), ny=>resolution(2), nz=>resolution(3) )

    select case(direction)
      case(1)
        do concurrent(iy=1:ny,iz=1:nz)
          grid_nodes(:,iy,iz) = [ boundaries(lo_bound,direction), (ix*dx(direction),ix=2,nx-1), boundaries(up_bound,direction) ]
        end do
      case(2)
        do concurrent(ix=1:nx,iz=1:nz)
          grid_nodes(ix,:,iz) = [ boundaries(lo_bound,direction), (iy*dx(direction),iy=2,ny-1), boundaries(up_bound,direction) ]
        end do
      case(3)
        do concurrent(ix=1:nx,iy=1:ny)
          grid_nodes(ix,iy,:) = [ boundaries(lo_bound,direction), (iz*dx(direction),iz=2,nz-1), boundaries(up_bound,direction) ]
        end do
      case default
        error stop "evenly_spaced_points: invalid direction"
    end select

    end associate

  end function

end program


      program try02

C     Check SRU format for dependence graph with non-uniform dependences

      real x(10,10,10)
      real s(10)

      do i = 1, 10
         s(i) = 0.
         do j = 1, 10
            do k = 1, 10
               s(i) = s(i) + x(i,j,k)
            enddo
         enddo
      enddo

      end


! ============================================================================
!  File:        geoclaw_module (for 1D)
! ============================================================================
!    Copyright (C) 2010-04-21 Clawpack Developers http://www.clawpack.org
!
!  Distributed under the terms of the Berkeley Software Distribution (BSD)
!  license
!                     http://www.opensource.org/licenses/
! ============================================================================

module geoclaw_module

    implicit none
    save

    ! ========================================================================
    !  Constants
    ! ========================================================================
    integer, parameter :: GEO_PARM_UNIT = 78
    integer, parameter :: KAPPA_UNIT = 42
    real(kind=8), parameter :: pi = 4.d0*datan(1.d0)
    real(kind=8), parameter :: DEG2RAD = pi / 180.d0
    real(kind=8), parameter :: RAD2DEG = 180.d0 / pi

    ! ========================================================================
    !  Physics
    ! ========================================================================
    real(kind=8) :: grav, earth_radius, sea_level
    integer :: coordinate_system

    ! Forcing
    ! friction
    real(kind=8) :: friction_depth, friction_coefficient, friction_forcing

    ! Method parameters
    real(kind=8) :: dry_tolerance

contains

    ! ========================================================================
    !  set_geo(fname)
    ! ========================================================================
    !  Reads in user parameters from the given file name if provided
    ! ========================================================================
    subroutine set_geo(file_name)

        implicit none

        ! Input
        character(len=*), intent(in), optional :: file_name

        ! Locals
        integer, parameter :: unit = 127

        open(unit=GEO_PARM_UNIT,file='fort.geo',status="unknown",action="write")

        write(GEO_PARM_UNIT,*) ' '
        write(GEO_PARM_UNIT,*) '--------------------------------------------'
        write(GEO_PARM_UNIT,*) 'Physics Parameters:'
        write(GEO_PARM_UNIT,*) '-------------------'

        ! Read user parameters from setgeo.data
        if (present(file_name)) then
            call opendatafile(unit, file_name)
        else
            call opendatafile(unit, 'geoclaw.data')
        endif

        read(unit,*) grav
        read(unit,*) earth_radius
        read(unit,*) coordinate_system
        read(unit,*) sea_level
        read(unit,*) friction_forcing
        read(unit,*) friction_coefficient
        read(unit,*) friction_depth
        read(unit,*) dry_tolerance

        close(unit)

        write(GEO_PARM_UNIT,*) '   gravity:',grav
        write(GEO_PARM_UNIT,*) '   earth_radius:',earth_radius
        write(GEO_PARM_UNIT,*) '   coordinate_system:',coordinate_system
        write(GEO_PARM_UNIT,*) '   sea_level:',sea_level
        write(GEO_PARM_UNIT,*) '   friction_forcing:',friction_forcing
        write(GEO_PARM_UNIT,*) '   friction_coefficient:', friction_coefficient
        write(GEO_PARM_UNIT,*) '   friction_depth:',friction_depth
        write(GEO_PARM_UNIT,*) '   dry_tolerance:',dry_tolerance

    end subroutine set_geo

end module geoclaw_module


PROGRAM F031

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: COMBINATIONS = 0

    INTEGER :: I, J, K, L, M, N, O, P

    DO I = 0, 200, 200
        DO J = 0, 200, 100
            DO K = 0, 200, 50
                DO L = 0, 200, 20
                    DO M = 0, 200, 10
                        DO N = 0, 200, 5
                            DO O = 0, 200, 2
                                DO P = 0, 200, 1
                                    IF ((I + J + K + L + M + N + O + P) == 200) THEN
                                        COMBINATIONS = COMBINATIONS + 1
                                    END IF
                                END DO
                            END DO
                        END DO
                    END DO
                END DO
            END DO
        END DO
    END DO

    PRINT ('(I0)'), COMBINATIONS

END PROGRAM F031


      subroutine sqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
      integer ldx,n,k,job,info
      real x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),xb(1)
c
c     sqrsl applies the output of sqrdc to compute coordinate
c     transformations, projections, and least squares solutions.
c     for k .le. min(n,p), let xk be the matrix
c
c            xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k)))
c
c     formed from columns jpvt(1), ... ,jpvt(k) of the original
c     n x p matrix x that was input to sqrdc (if no pivoting was
c     done, xk consists of the first k columns of x in their
c     original order).  sqrdc produces a factored orthogonal matrix q
c     and an upper triangular matrix r such that
c
c              xk = q * (r)
c                       (0)
c
c     this information is contained in coded form in the arrays
c     x and qraux.
c
c     on entry
c
c        x      real(ldx,p).
c               x contains the output of sqrdc.
c
c        ldx    integer.
c               ldx is the leading dimension of the array x.
c
c        n      integer.
c               n is the number of rows of the matrix xk.  it must
c               have the same value as n in sqrdc.
c
c        k      integer.
c               k is the number of columns of the matrix xk.  k
c               must nnot be greater than min(n,p), where p is the
c               same as in the calling sequence to sqrdc.
c
c        qraux  real(p).
c               qraux contains the auxiliary output from sqrdc.
c
c        y      real(n)
c               y contains an n-vector that is to be manipulated
c               by sqrsl.
c
c        job    integer.
c               job specifies what is to be computed.  job has
c               the decimal expansion abcde, with the following
c               meaning.
c
c                    if a.ne.0, compute qy.
c                    if b,c,d, or e .ne. 0, compute qty.
c                    if c.ne.0, compute b.
c                    if d.ne.0, compute rsd.
c                    if e.ne.0, compute xb.
c
c               note that a request to compute b, rsd, or xb
c               automatically triggers the computation of qty, for
c               which an array must be provided in the calling
c               sequence.
c
c     on return
c
c        qy     real(n).
c               qy conntains q*y, if its computation has been
c               requested.
c
c        qty    real(n).
c               qty contains trans(q)*y, if its computation has
c               been requested.  here trans(q) is the
c               transpose of the matrix q.
c
c        b      real(k)
c               b contains the solution of the least squares problem
c
c                    minimize norm2(y - xk*b),
c
c               if its computation has been requested.  (note that
c               if pivoting was requested in sqrdc, the j-th
c               component of b will be associated with column jpvt(j)
c               of the original matrix x that was input into sqrdc.)
c
c        rsd    real(n).
c               rsd contains the least squares residual y - xk*b,
c               if its computation has been requested.  rsd is
c               also the orthogonal projection of y onto the
c               orthogonal complement of the column space of xk.
c
c        xb     real(n).
c               xb contains the least squares approximation xk*b,
c               if its computation has been requested.  xb is also
c               the orthogonal projection of y onto the column space
c               of x.
c
c        info   integer.
c               info is zero unless the computation of b has
c               been requested and r is exactly singular.  in
c               this case, info is the index of the first zero
c               diagonal element of r and b is left unaltered.
c
c     the parameters qy, qty, b, rsd, and xb are not referenced
c     if their computation is not requested and in this case
c     can be replaced by dummy variables in the calling program.
c     to save storage, the user may in some cases use the same
c     array for different parameters in the calling sequence.  a
c     frequently occurring example is when one wishes to compute
c     any of b, rsd, or xb and does not need y or qty.  in this
c     case one may identify y, qty, and one of b, rsd, or xb, while
c     providing separate arrays for anything else that is to be
c     computed.  thus the calling sequence
c
c          call sqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info)
c
c     will result in the computation of b and rsd, with rsd
c     overwriting y.  more generally, each item in the following
c     list contains groups of permissible identifications for
c     a single callinng sequence.
c
c          1. (y,qty,b) (rsd) (xb) (qy)
c
c          2. (y,qty,rsd) (b) (xb) (qy)
c
c          3. (y,qty,xb) (b) (rsd) (qy)
c
c          4. (y,qy) (qty,b) (rsd) (xb)
c
c          5. (y,qy) (qty,rsd) (b) (xb)
c
c          6. (y,qy) (qty,xb) (b) (rsd)
c
c     in any group the value returned in the array allocated to
c     the group corresponds to the last member of the group.
c
c     linpack. this version dated 08/14/78 .
c     g.w. stewart, university of maryland, argonne national lab.
c
c     sqrsl uses the following functions and subprograms.
c
c     blas saxpy,scopy,sdot
c     fortran abs,min0,mod
c
c     internal variables
c
      integer i,j,jj,ju,kp1
      real sdot,t,temp
      logical cb,cqy,cqty,cr,cxb
c
c
c     set info flag.
c
      info = 0
c
c     determine what is to be computed.
c
      cqy = job/10000 .ne. 0
      cqty = mod(job,10000) .ne. 0
      cb = mod(job,1000)/100 .ne. 0
      cr = mod(job,100)/10 .ne. 0
      cxb = mod(job,10) .ne. 0
      ju = min0(k,n-1)
c
c     special action when n=1.
c
      if (ju .ne. 0) go to 40
         if (cqy) qy(1) = y(1)
         if (cqty) qty(1) = y(1)
         if (cxb) xb(1) = y(1)
         if (.not.cb) go to 30
            if (x(1,1) .ne. 0.0e0) go to 10
               info = 1
            go to 20
   10       continue
               b(1) = y(1)/x(1,1)
   20       continue
   30    continue
         if (cr) rsd(1) = 0.0e0
      go to 250
   40 continue
c
c        set up to compute qy or qty.
c
         if (cqy) call scopy(n,y,1,qy,1)
         if (cqty) call scopy(n,y,1,qty,1)
         if (.not.cqy) go to 70
c
c           compute qy.
c
            do 60 jj = 1, ju
               j = ju - jj + 1
               if (qraux(j) .eq. 0.0e0) go to 50
                  temp = x(j,j)
                  x(j,j) = qraux(j)
                  t = -sdot(n-j+1,x(j,j),1,qy(j),1)/x(j,j)
                  call saxpy(n-j+1,t,x(j,j),1,qy(j),1)
                  x(j,j) = temp
   50          continue
   60       continue
   70    continue
         if (.not.cqty) go to 100
c
c           compute trans(q)*y.
c
            do 90 j = 1, ju
               if (qraux(j) .eq. 0.0e0) go to 80
                  temp = x(j,j)
                  x(j,j) = qraux(j)
                  t = -sdot(n-j+1,x(j,j),1,qty(j),1)/x(j,j)
                  call saxpy(n-j+1,t,x(j,j),1,qty(j),1)
                  x(j,j) = temp
   80          continue
   90       continue
  100    continue
c
c        set up to compute b, rsd, or xb.
c
         if (cb) call scopy(k,qty,1,b,1)
         kp1 = k + 1
         if (cxb) call scopy(k,qty,1,xb,1)
         if (cr .and. k .lt. n) call scopy(n-k,qty(kp1),1,rsd(kp1),1)
         if (.not.cxb .or. kp1 .gt. n) go to 120
            do 110 i = kp1, n
               xb(i) = 0.0e0
  110       continue
  120    continue
         if (.not.cr) go to 140
            do 130 i = 1, k
               rsd(i) = 0.0e0
  130       continue
  140    continue
         if (.not.cb) go to 190
c
c           compute b.
c
            do 170 jj = 1, k
               j = k - jj + 1
               if (x(j,j) .ne. 0.0e0) go to 150
                  info = j
c           ......exit
                  go to 180
  150          continue
               b(j) = b(j)/x(j,j)
               if (j .eq. 1) go to 160
                  t = -b(j)
                  call saxpy(j-1,t,x(1,j),1,b,1)
  160          continue
  170       continue
  180       continue
  190    continue
         if (.not.cr .and. .not.cxb) go to 240
c
c           compute rsd or xb as required.
c
            do 230 jj = 1, ju
               j = ju - jj + 1
               if (qraux(j) .eq. 0.0e0) go to 220
                  temp = x(j,j)
                  x(j,j) = qraux(j)
                  if (.not.cr) go to 200
                     t = -sdot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j)
                     call saxpy(n-j+1,t,x(j,j),1,rsd(j),1)
  200             continue
                  if (.not.cxb) go to 210
                     t = -sdot(n-j+1,x(j,j),1,xb(j),1)/x(j,j)
                     call saxpy(n-j+1,t,x(j,j),1,xb(j),1)
  210             continue
                  x(j,j) = temp
  220          continue
  230       continue
  240    continue
  250 continue
      return
      end


      programs_psc
      realpi,rapdeg,rapmin,rapsec
      complexiu
      realLCn2
      realLs,Lp
      integerNs,Np
      parameter(Ns=512)
      parameter(Np=Ns/2)
      realk,kapmax,kapmin,L0,dkap,lo
      reallambda,fraction
      integernsamp
      complexpsc(Ns,Ns)
      realpwr(Np,Np)
      integerMaxcomp,Maxap
      parameter(Maxcomp=50,Maxap=15)
      reals_int(Maxcomp),s_pos(Maxcomp,2)
      realc_pos(Maxap,2),c_rad(Maxap)
      integerc_typ(Maxap)
      realx_min,x_max,xstep,y_min,y_max,ystep
      integerncomp,ncircle,nframe
      common/psc/pi,rapdeg,rapmin,rapsec,iu,k,kapmax,kapmin,L0,LCn2,Ls,L
     +p,dkap,lambda,nframe,x_min,x_max,xstep,y_min,y_max,ystep,ncomp,nci
     +rcle,nsamp,fraction
      realimage1(Np,Np),image2(Np,Np),ary1(Np,Np),ary2(Np,Np)
      complexpdata1(Np,Np),pdata2(Np,Np),cary1(Np,Np),cary2(Np,Np)
      realzero
      integerseed,n,iscreen,iframe,iz,jz,lx,ly
      logicalno_dist,w_screen,w_image,w_power
      charactercomment*80
      pi=3.141592653
      rapdeg=pi/180.0
      rapmin=rapdeg/60.0
      rapsec=rapdeg/3600.0
      iu=(0.0,1.0)
      LCn2=5.0e-13
      Ls=10.24
      Lp=0.02
      callinit()
      nframe=50
      x_min=2.5
      y_min=2.5
      x_max=8.5
      y_max=8.5
      xstep=.15
      ystep=8.0
      calluserint(nframe,1,1,'NFRAME=','Enter the number of frames')
      calluserrpair(x_min,y_min,1,'SUB_MIN=','Enter minimum X,Y of subfr
     +ame (m)')
      calluserrpair(x_max,y_max,1,'SUB_MAX=','Enter maximum X,Y of subfr
     +ame (m)')
      calluserrpair(xstep,ystep,1,'SUB_STEP=','Enter stepsize in X,Y (m)
     +')
      L0=0.60
      lo=0.02
      calluserrpair(L0,lo,2,'SCALE=','Enter outer,inner scale of turbule
     +nce (m)')
      lambda=0.63e-6
      fraction=0.00476
      nsamp=3
      calluserreal(lambda,1,2,'LAMBDA=','Enter wavelength (m)')
      calluserreal(fraction,1,2,'FBAND=','Enter fractional bandwidth')
      calluserint(nsamp,1,2,'NSAMP=','Enter number of sampling points')
      ncircle=1
      c_rad(1)=1.
      c_pos(1,1)=0.0
      c_pos(1,2)=0.0
      c_typ(1)=1
      calluserint(ncircle,1,1,'NCIRCLE=','Enter number of apertures')
      DO80000n=1,ncircle
      calluserrpair(c_pos(n,1),c_pos(n,2),1,'CPOS=','Enter position in X
     +,Y (m)')
      calluserreal(c_rad(n),1,1,'CRAD=','Enter radius (m)')
      calluserint(c_typ(n),1,1,'CTYPE=','Enter type (1=hole,0=void)')
      c_rad(n+1)=c_rad(n)
      c_pos(n+1,1)=c_pos(n,1)
      c_pos(n+1,2)=c_pos(n,1)
      c_typ(n+1)=c_typ(n)
      callcancel('CPOS=')
      callcancel('CRAD=')
      callcancel('CTYPE=')
80000 CONTINUE
      ncomp=1
      calluserint(ncomp,1,1,'NCOMP=','Enter number of sources')
      DO80001n=1,ncomp
      s_int(n)=1.
      s_pos(n,1)=0.0
      s_pos(n,2)=0.0
      calluserrpair(s_pos(n,1),s_pos(n,2),1,'SPOS=','Enter position in X
     +,Y (m)')
      calluserreal(s_int(n),1,1,'SINT=','Enter intensity')
      callcancel('SPOS=')
      callcancel('SINT=')
80001 CONTINUE
      no_dist=.FALSE.
      w_screen=.FALSE.
      w_image=.FALSE.
      w_power=.TRUE.
      calluserlog(no_dist,1,2,'NDIST=','No disturbance?')
      calluserlog(w_screen,1,2,'WSCREEN=','Write screen data?')
      calluserlog(w_image,1,2,'WIMAGE=','Write image plane?')
      calluserlog(w_power,1,2,'WPOWER=','Write power spectrum?')
      seed=7597551
      calluserint(seed,1,2,'SEED=','Enter seed for random generator')
      k=2.0*pi/lambda
      if(Ls.lt.L0)then
      kapmin=2.0*pi/Ls
      else
      kapmin=2.0*pi/L0
      endif
      if(lo.lt.Lp)then
      kapmax=2.0*pi/Lp
      else
      kapmax=2.0*pi/lo
      endif
      dkap=2.0*pi/Ls
      write(1,*)'frm_per_scr ',(int((x_max-x_min)/xstep)+1)*(int((y_max-
     +y_min)/ystep)+1)
      iframe=1
      iscreen=1
  287 if(no_dist)then
      DO80002iz=1,Ns
      DO80003jz=1,Ns
      psc(iz,jz)=(0.0,0.0)
80003 CONTINUE
80002 CONTINUE
      else
      write(comment,310)iscreen
  310 format(' Generating ',i3,'th complex phase screen')
      callscreen(psc,Ns,seed)
      iscreen=iscreen+1
      if(w_screen)callpsc_wscreen(psc,Ns,Ns,pdata1,pdata2,Np,Np)
      endif
      callpower(psc,Ns,pwr,Np,iframe,Maxcomp,Maxap,s_int,s_pos,c_pos,c_r
     +ad,c_typ,pdata1,pdata2,image1,image2,ary1,ary2,cary1,cary2)
      if(w_image)callpsc_wimage(ary1,ary2,Np,Np)
      if(iframe.le.nframe)goto287
      zero=pwr(Np/2+1,Np/2+1)
      if(zero.eq.0.0)zero=1.0
      write(1,*)'Scaling: divide by ',zero
      DO80004ly=1,Np
      DO80005lx=1,Np
      pwr(lx,ly)=pwr(lx,ly)/zero
80005 CONTINUE
80004 CONTINUE
      print*,'Scaled'
      if(w_power)callpsc_wpower(pwr,Np,Np)
      n=0
      calldata_close(1,n)
      n=0
      calldata_close(2,n)
      n=0
      calldata_close(3,n)
      callfinis()
      end
      subroutinescreen(psc,Ns,seed)
      implicitnone
      integerNs,seed
      complexpsc(Ns,Ns)
      realpi,rapdeg,rapmin,rapsec,Ls,Lp
      complexiu
      realk,kapmax,kapmin,L0,LCn2,dkap,lambda,fraction
      realx_min,x_max,xstep,y_min,y_max,ystep
      integerncomp,ncircle,nsamp,nframe
      common/psc/pi,rapdeg,rapmin,rapsec,iu,k,kapmax,kapmin,L0,LCn2,Ls,L
     +p,dkap,lambda,nframe,x_min,x_max,xstep,y_min,y_max,ystep,ncomp,nci
     +rcle,nsamp,fraction
      realkap
      integerN(2),Nc
      integeri,j,jx,jy
      realFs,Fs0,atten,radi,u,ran
      charactercomment*80
      N(1)=Ns
      N(2)=Ns
      callfour2(psc,Ns,Ns,0)
      Nc=Ns/2+1
      Fs0=0.033*pi*LCn2*k*k*2.0*dkap*dkap
      do100jy=1,Ns
      if(mod(jy,100).eq.0)then
      write(comment,*)'Making line ',jy
      callstatus(comment)
      endif
      do110jx=1,Ns
      kap=dkap*sqrt(float((jx-Nc)**2+(jy-Nc)**2))
      if(kap.gt.kapmax)atten=exp(-(kap-kapmax)/(5.0*dkap))
      if(kap.lt.kapmin)atten=exp(-(kapmin-kap)/(5.0*dkap))
      if(kap.le.kapmax.and.kap.ge.kapmin)atten=1.0
      if(kap.eq.0.0)kap=dkap
      u=0.0
  288 u=ran(seed)
      if(u.le.0.0)goto288
      radi=sqrt(-2.0*log(u))
      Fs=Fs0*kap**(-11.0/3.0)
      psc(jx,jy)=atten*sqrt(Fs)*radi*cexp(iu*2.0*pi*ran(seed))
  110 continue
  100 continue
      DO80006j=1,Ns,2
      DO80007i=1,Ns,2
      psc(i+1,j)=-psc(i+1,j)
      psc(i,j+1)=-psc(i,j+1)
80007 CONTINUE
80006 CONTINUE
      write(comment,555)N(1),N(2)
  555 format(' ','start ',i3,'x',i3,' sized fft              ')
      callfour2(psc,Ns,Ns,-1)
      write(comment,666)
  666 format(' ','end fft for screen                         ')
      DO80008j=1,Ns,2
      DO80009i=1,Ns,2
      psc(i+1,j)=-psc(i+1,j)
      psc(i,j+1)=-psc(i,j+1)
80009 CONTINUE
80008 CONTINUE
      return
      end
      subroutinepower(psc,Ns,pwr,Np,iframe,Maxcomp,Maxap,s_int,s_pos,c_p
     +os,c_rad,c_typ,pdata1,pdata2,image1,image2,ary1,ary2,cary1,cary2)
      implicitnone
      integerNs,Np,iframe,Maxcomp,Maxap
      reals_int(Maxcomp),s_pos(Maxcomp,2)
      realc_pos(Maxap,2),c_rad(Maxap)
      integerc_typ(Maxap)
      complexpsc(Ns,Ns)
      realpwr(Np,Np)
      realimage1(Np,Np),image2(Np,Np),ary1(Np,Np),ary2(Np,Np)
      complexpdata1(Np,Np),pdata2(Np,Np),cary1(Np,Np),cary2(Np,Np)
      realpi,rapdeg,rapmin,rapsec,Ls,Lp
      complexiu
      realk,kapmax,kapmin,L0,LCn2,dkap,lambda,fraction
      realx_min,x_max,xstep,y_min,y_max,ystep
      integerncomp,ncircle,nsamp,nframe
      common/psc/pi,rapdeg,rapmin,rapsec,iu,k,kapmax,kapmin,L0,LCn2,Ls,L
     +p,dkap,lambda,nframe,x_min,x_max,xstep,y_min,y_max,ystep,ncomp,nci
     +rcle,nsamp,fraction
      integerN(2),Wc,Npx
      reallpix,Scale,factor
      realx,y,xa,ya,ox,oy
      integerix,iy,jx,jy,lx,ly,dx,dy,iox,ioy
      integerloop1,loop2,i
      charactercomment*80
      N(1)=Np
      N(2)=Np
      callfour2(pdata1,Np,Np,0)
      lpix=Ls/Ns
      Wc=Np/2+1
      Scale=Ls/lambda*Np/Ns*rapsec
      do10x=x_min,x_max,xstep
      do20y=y_min,y_max,ystep
      write(1,111)x,y
  111 format(' ',' creating a pair of speckle/fringe patterns',1x,'xy',f
     +10.3,1x,f10.3)
      DO80010jy=1,Np
      DO80011jx=1,Np
      image1(jx,jy)=0.0
      image2(jx,jy)=0.0
      ary1(jx,jy)=0.0
      ary2(jx,jy)=0.0
      cary1(jx,jy)=(0.0,0.0)
      cary2(jx,jy)=(0.0,0.0)
80011 CONTINUE
80010 CONTINUE
      do100loop1=1,nsamp
      DO80012iy=1,Np
      DO80013ix=1,Np
      pdata1(ix,iy)=(0.0,0.0)
      pdata2(ix,iy)=(0.0,0.0)
80013 CONTINUE
80012 CONTINUE
      factor=1.0+fraction*float(loop1-nsamp/2)
      npx=0
      do30i=1,ncircle
      do40xa=x+c_pos(i,1)-c_rad(i),x+c_pos(i,1)+c_rad(i),lpix
      do50ya=y+c_pos(i,2)-c_rad(i),y+c_pos(i,2)+c_rad(i),lpix
      ox=xa-x-c_pos(i,1)
      oy=ya-y-c_pos(i,2)
      if(ox*ox+oy*oy.lt.c_rad(i)*c_rad(i))then
      ix=nint((xa-x)/lpix)+Wc
      iy=nint((ya-y)/lpix)+Wc
      lx=nint(xa/lpix)
      ly=nint(ya/lpix)
      if(c_typ(i).eq.1)npx=npx+1
      if(c_typ(i).eq.0)npx=npx-1
      if(npx.eq.1.or.mod(npx,100).eq.0)then
      write(comment,777)npx
      callstatus(comment)
      endif
  777 format('# of  positive pixels',1x,i5)
      if(mod(ix+iy,2).eq.0)then
      pdata1(ix,iy)=cexp(iu*factor*real(psc(lx,ly)))*c_typ(i)
      pdata2(ix,iy)=cexp(iu*factor*aimag(psc(lx,ly)))*c_typ(i)
      else
      pdata1(ix,iy)=-cexp(iu*factor*real(psc(lx,ly)))*c_typ(i)
      pdata2(ix,iy)=-cexp(iu*factor*aimag(psc(lx,ly)))*c_typ(i)
      endif
      endif
   50 continue
   40 continue
   30 continue
      callfour2(pdata1,Np,Np,-1)
      callfour2(pdata2,Np,Np,-1)
      DO80014iy=1,Np
      DO80015ix=1,Np
      image1(ix,iy)=image1(ix,iy)+real(pdata1(ix,iy)*conjg(pdata1(ix,iy)
     +))
      image2(ix,iy)=image2(ix,iy)+real(pdata2(ix,iy)*conjg(pdata2(ix,iy)
     +))
80015 CONTINUE
80014 CONTINUE
  100 continue
      do60loop2=1,ncomp
      dx=int(Scale*s_pos(loop2,1))
      dy=int(Scale*s_pos(loop2,2))
      iox=0
      ioy=0
      if(dx.lt.0)iox=dx
      if(dy.lt.0)ioy=dy
      DO80016iy=1-ioy,Np-dy+ioy
      DO80017ix=1-iox,Np-dx+iox
      ary1(ix+dx,iy+dy)=ary1(ix,iy)+s_int(loop2)*image1(ix,iy)
      ary2(ix+dx,iy+dy)=ary2(ix,iy)+s_int(loop2)*image2(ix,iy)
80017 CONTINUE
80016 CONTINUE
   60 continue
      write(comment,320)iframe
      DO80018iy=1,Np,2
      DO80019ix=1,Np,2
      cary1(ix,iy)=ary1(ix,iy)
      cary1(ix+1,iy+1)=ary1(ix+1,iy+1)
      cary1(ix+1,iy)=-ary1(ix+1,iy)
      cary1(ix,iy+1)=-ary1(ix,iy+1)
80019 CONTINUE
80018 CONTINUE
      callfour2(cary1,Np,Np,-1)
      DO80020jy=1,Np
      DO80021jx=1,Np
      pwr(jx,jy)=pwr(jx,jy)+real(cary1(jx,jy)*conjg(cary1(jx,jy)))
80021 CONTINUE
80020 CONTINUE
      iframe=iframe+1
      if(iframe.gt.nframe)return
      write(comment,320)iframe
  320 format(' ','processing ',i4,' th frame                    ')
      DO80022iy=1,Np,2
      DO80023ix=1,Np,2
      cary2(ix,iy)=ary2(ix,iy)
      cary2(ix+1,iy+1)=ary2(ix+1,iy+1)
      cary2(ix+1,iy)=-ary2(ix+1,iy)
      cary2(ix,iy+1)=-ary2(ix,iy+1)
80023 CONTINUE
80022 CONTINUE
      callfour2(cary2,Np,Np,-1)
      DO80024jy=1,Np
      DO80025jx=1,Np
      pwr(jx,jy)=pwr(jx,jy)+real(cary2(jx,jy)*conjg(cary2(jx,jy)))
80025 CONTINUE
80024 CONTINUE
      iframe=iframe+1
      if(iframe.gt.nframe)return
   20 continue
   10 continue
      end
      subroutinepsc_wscreen(array,dx,dy,rbuf,ibuf,nx,ny)
      implicitnone
      integerdx,dy,nx,ny
      complexarray(dx,dy)
      realrbuf(nx,ny),ibuf(nx,ny)
      characterofile*25,otype*10,oform*5
      integererr,ix,iy,x0,y0
      logicalfirst
      datafirst/.TRUE./
      savefirst
      err=0
      if(first)then
      first=.false.
      ofile=' '
      otype='GHRIL'
      oform='-32'
      callusertext(ofile,1,'SFILE=','Enter filename for phase-screen')
      callusertext(otype,2,'STYPE=','Enter file-type')
      callusertext(oform,2,'SFORM=','Enter format for GHRIL-file')
      calldata_open(1,ofile,otype,'WRITE',err)
      calldata_wkey(1,'OBJECT','Screen',' ',err)
      calldate_header(1,'DATE','TIME')
      endif
      DO80026x0=0,dx-1,nx
      DO80027y0=0,dy-1,nx
      DO80028iy=1,ny
      DO80029ix=1,nx
      rbuf(ix,iy)=real(array(x0+ix,y0+iy))
      ibuf(ix,iy)=aimag(array(x0+ix,y0+iy))
80029 CONTINUE
80028 CONTINUE
      calldata_write(1,0,0,1,nx,ny,rbuf,0,0,nx,oform,err)
      calldata_write(1,0,0,1,nx,ny,ibuf,0,0,nx,oform,err)
80027 CONTINUE
80026 CONTINUE
      calldata_error(err)
      return
      end
      subroutinepsc_wimage(array1,array2,dx,dy)
      implicitnone
      realarray1(*),array2(*)
      integerdx,dy
      characterofile*25,otype*10,oform*5
      integererr
      logicalfirst
      datafirst/.TRUE./
      savefirst
      err=0
      if(first)then
      first=.false.
      ofile=' '
      otype='GHRIL'
      oform='-32'
      callusertext(ofile,1,'IFILE=','Enter filename for image-plane')
      callusertext(otype,2,'ITYPE=','Enter file-type')
      callusertext(oform,2,'SFORM=','Enter format for GHRIL-file')
      calldata_open(2,ofile,otype,'WRITE',err)
      calldata_wkey(2,'OBJECT','Image',' ',err)
      calldate_header(2,'DATE','TIME')
      endif
      calldata_write(2,0,0,1,dx,dy,array1,0,0,dx,oform,err)
      calldata_write(2,0,0,1,dx,dy,array2,0,0,dx,oform,err)
      calldata_error(err)
      return
      end
      subroutinepsc_wpower(array,dx,dy)
      implicitnone
      realarray(*)
      integerdx,dy
      characterofile*25,otype*10,oform*5
      integererr
      logicalfirst
      datafirst/.TRUE./
      savefirst
      err=0
      if(first)then
      first=.false.
      ofile=' '
      otype='GHRIL'
      oform='-32'
      callusertext(ofile,1,'PFILE=','Enter filename for power spectrum')
      callusertext(otype,2,'PTYPE=','Enter file-type')
      callusertext(oform,2,'SFORM=','Enter format for GHRIL-file')
      calldata_open(3,ofile,otype,'WRITE',err)
      calldata_wkey(3,'OBJECT','Power',' ',err)
      calldate_header(3,'DATE','TIME')
      endif
      calldata_write(3,0,0,1,dx,dy,array,0,0,dx,oform,err)
      calldata_error(err)
      return
      end


program paladino
integer a, b, c, d, i, k ; k = 0
do i = 1000, 9999, 9 ; a = i/1000
b = (mod(i,1000))/100 ; c = (mod(i,100))/10
d = mod(i,10) ; if((a*b*c*d)/=0) then
print*,i ; k = k + 1 ; end if ; end do
print*,k ; end program


MODULE float_precision
  IMPLICIT NONE
  ! to make the range and precision of float point numbers more portable
  INTEGER,PARAMETER :: DPR = SELECTED_REAL_KIND(15,307)  ! i.e., to keep 15 sig digits, and the range is 10^{-307} to 10^{307}.
  INTEGER,PARAMETER :: CDPR = SELECTED_REAL_KIND(15,307)  ! long complex type
  INTEGER,PARAMETER :: SPR = SELECTED_REAL_KIND(7,37)   ! the usual single precision real value

END MODULE float_precision

MODULE derived_data_module

  USE float_precision, ONLY: DPR, CDPR
  IMPLICIT NONE
  ! Declare type node_info;

  TYPE:: geometry_node_type
     ! basic mesh-related geometric node type
     INTEGER    :: bud     ! boundary info:
     !  bud == 1 : on the computational outer boundaries;
     !  bud /= 1 : inside computational outer boundaries, in this case,
     !             value of 'reg' equals to the attribute value of the region
     !             in which the node is located.
     INTEGER,ALLOCATABLE    :: reg(:)       ! regional attribution info
     REAL(DPR)  :: x       ! x-coordinate
     REAL(DPR)  :: y       ! y-coordinate
     REAL(DPR)  :: z       ! z-coordinate
  end type geometry_node_type

  TYPE,EXTENDS(geometry_node_type):: geoph_grav_node_type
     REAL(DPR)  :: rho     ! physical property, density (kg/m^3)
     REAL(DPR)  :: phig     ! gravity potential data (m^2/ s^2), or other real-valued scalar potential (e.g., DC)
  end TYPE geoph_grav_node_type

  TYPE,EXTENDS(geoph_grav_node_type) :: geoph_EM_node_type
     REAL(DPR)  :: sigma     ! physical property, conductivity
     REAL(DPR)  :: mu        ! physical property, magnetic permeability
     REAL(DPR)  :: permt     ! physical property, electrical permittivity

     COMPLEX(CDPR)  :: A(3)  !  vector potential value associated
     COMPLEX(CDPR)  :: phi   ! EM scalar potential
     COMPLEX(CDPR)  :: E(3)   ! scalar components of Electric field
     COMPLEX(CDPR)  :: H(3)   ! scalar components of magnetic field
  END type Geoph_EM_Node_Type

  TYPE(geometry_node_type),ALLOCATABLE :: nodes(:)
  TYPE(geoph_EM_node_type),ALLOCATABLE :: dofs(:)

CONTAINS
  SUBROUTINE deep_node_copy(nod1, nod2)
    ! COPY nod1 TO nod2
    IMPLICIT NONE
    TYPE(geoph_EM_node_type),INTENT(IN) :: nod1
    TYPE(geoph_EM_node_type),INTENT(INOUT) :: nod2
    nod2%x = nod1%x
    nod2%y = nod1%y
    nod2%z = nod1%z
    nod2%reg = nod1%reg
    nod2%bud = nod1%bud
    nod2%rho = nod1%rho
    nod2%sigma = nod1%sigma
    nod2%mu = nod1%mu
    nod2%permt = nod1%permt
    nod2%phig = nod1%phig
    nod2%A = nod1%A
    nod2%phi = nod1%phi
    nod2%E = nod1%E
    nod2%H = nod1%H
    RETURN
  end SUBROUTINE deep_node_copy

  SUBROUTINE deep_node_copy_geometry2EM(nod1, nod2)
    ! COPY nod1 of geometry type TO nod2 of EM type
    IMPLICIT NONE
    TYPE(geometry_node_type),INTENT(IN) :: nod1
    TYPE(geoph_EM_node_type),INTENT(INOUT) :: nod2
    nod2%x = nod1%x
    nod2%y = nod1%y
    nod2%z = nod1%z
    nod2%reg = nod1%reg
    nod2%bud = nod1%bud
    RETURN
  end SUBROUTINE deep_node_copy_geometry2EM

END MODULE Derived_Data_Module

MODULE constants_module
  !
  ! Purpose: assign physical or mathematical constants in a finite-precison type
  !
  USE float_precision, ONLY: DPR
  IMPLICIT NONE

  ! Newton's gravitational constant, SI unit: m^3.Kg^-1.s^-2
  REAL(DPR),PARAMETER  :: gravity_cst = 6.67408d-11

  REAL(DPR),PARAMETER  :: pi = 3.14159d0

  REAL(DPR),PARAMETER  :: mu0 = 4 * pi * 1.D-7

  REAL(DPR),PARAMETER  :: epsilon0 = 8.854187817 * 1.D-12

  COMPLEX(DPR),PARAMETER :: cmpx_one = CMPLX( 1.d0, 0.d0, KIND= DPR )

  COMPLEX(DPR),PARAMETER :: cmpx_i = CMPLX( 0.d0, 1.d0, KIND= DPR )

  COMPLEX(DPR),PARAMETER :: cmpx_zero = CMPLX( 0.d0, 0.d0, KIND= DPR )

  ! unit normal vector in 3D Cartesian coordinates
  REAL(DPR),PROTECTED :: unit_vec_x(3) = [ 1.d0, 0.d0, 0.d0 ]
  REAL(DPR),PROTECTED :: unit_vec_y(3) = [ 0.d0, 1.d0, 0.d0 ]
  REAL(DPR),PROTECTED :: unit_vec_z(3) = [ 0.d0, 0.d0, 1.d0 ]

END MODULE constants_module


module stats_mod
    implicit none

    private

    type, public :: stats_t
        real :: sum, sum2
        integer :: n
    end type stats_t

end module stats_mod