 SUBROUTINE POLATES1(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
                     MI,MO,KM,IBI,LI,GI, &
                     NO,RLAT,RLON,IBO,LO,GO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATES1   INTERPOLATE SCALAR FIELDS (BICUBIC)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS BICUBIC INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR SCALAR FIELDS.
!           BITMAPS ARE NOW ALLOWED EVEN WHEN INVALID POINTS ARE WITHIN
!           THE BICUBIC TEMPLATE PROVIDED THE MINIMUM WEIGHT IS REACHED.
!           OPTIONS ALLOW CHOICES BETWEEN STRAIGHT BICUBIC (IPOPT(1)=0)
!           AND CONSTRAINED BICUBIC (IPOPT(1)=1) WHERE THE VALUE IS
!           CONFINED WITHIN THE RANGE OF THE SURROUNDING 16 POINTS.
!           ANOTHER OPTION IS THE MINIMUM PERCENTAGE FOR MASK,
!           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
!           (IPOPT(2)) WHICH DEFAULTS TO 50 (IF IPOPT(2)=-1).
!           BILINEAR USED WITHIN ONE GRID LENGTH OF BOUNDARIES.
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!           THE CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMI/O=01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMI/O=10) MERCATOR CYLINDRICAL
!             (IGDTNUMI/O=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMI/O=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED.
!           ON THE OTHER HAND, THE OUTPUT CAN BE A SET OF STATION POINTS
!           IF IGDTNUMO<0, IN WHICH CASE THE NUMBER OF POINTS
!           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT.
!           OUTPUT BITMAPS WILL ONLY BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
! 2007-05-22  IREDELL  EXTRAPOLATE UP TO HALF A GRID CELL
! 2007-10-30  IREDELL  CORRECT NORTH POLE INDEXING PROBLEM,
!                      UNIFY MASKED AND NON-MASKED ALGORITHMS,
!                      AND SAVE WEIGHTS FOR PERFORMANCE.
! 2012-06-26  GAYNO    FIX OUT-OF-BOUNDS ERROR.  SEE NCEPLIBS
!                      TICKET #9.
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      VERSION OF GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATES1(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
!                         MI,MO,KM,IBI,LI,GI, &
!                         NO,RLAT,RLON,IBO,LO,GO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1)=0 FOR STRAIGHT BICUBIC;
!                IPOPT(1)=1 FOR CONSTRAINED BICUBIC WHERE VALUE IS
!                CONFINED WITHIN THE RANGE OF THE SURROUNDING 4 POINTS.
!                IPOPT(2) IS MINIMUM PERCENTAGE FOR MASK
!                (DEFAULTS TO 50 IF IPOPT(2)=-1)
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE. IGDTNUMO<0
!                MEANS INTERPOLATE TO RANDOM STATION POINTS.
!                OTHERWISE, SAME DEFINITION AS "IGDTNUMI".
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     GI       - REAL (MI,KM) INPUT FIELDS TO INTERPOLATE
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO<0)
!     RLAT     - REAL (NO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO<0)
!     RLON     - REAL (NO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO<0)
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO>=0)
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO>=0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO>=0)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     GO       - REAL (MO,KM) OUTPUT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!
! SUBPROGRAMS CALLED:
!   GDSWZD       GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
!   IJKGDS1      RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   POLFIXS      MAKE MULTIPLE POLE SCALAR VALUES CONSISTENT
!   CHECK_GRIDS1 DETERMINE IF INPUT OR OUTPUT GRIDS HAVE CHANGED
!                BETWEEN CALLS TO THIS ROUTINE.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   )         :: IGDTNUMI, IGDTLENI
 INTEGER,        INTENT(IN   )         :: IGDTMPLI(IGDTLENI)
 INTEGER,        INTENT(IN   )         :: IGDTNUMO, IGDTLENO
 INTEGER,        INTENT(IN   )         :: IGDTMPLO(IGDTLENO)
 INTEGER,                INTENT(IN   ) :: IPOPT(20)
 INTEGER,                INTENT(IN   ) :: MI,MO,KM
 INTEGER,                INTENT(IN   ) :: IBI(KM)
 INTEGER,                INTENT(INOUT) :: NO
 INTEGER,                INTENT(  OUT) :: IRET, IBO(KM)
!
 LOGICAL*1,              INTENT(IN   ) :: LI(MI,KM)
 LOGICAL*1,              INTENT(  OUT) :: LO(MO,KM)
!
 REAL,                   INTENT(IN   ) :: GI(MI,KM)
 REAL,                   INTENT(INOUT) :: RLAT(MO),RLON(MO)
 REAL,                   INTENT(  OUT) :: GO(MO,KM)
!
 REAL,                   PARAMETER     :: FILL=-9999.
!
 INTEGER                               :: IJKGDSA(20)
 INTEGER                               :: IJX(4),IJY(4)
 INTEGER                               :: MCON,MP,N,I,J,K
 INTEGER                               :: NK,NV,IJKGDS1
 INTEGER,            SAVE              :: NOX=-1,IRETX=-1
 INTEGER,            ALLOCATABLE,SAVE  :: NXY(:,:,:),NC(:)
!
 LOGICAL                               :: SAME_GRIDI, SAME_GRIDO
!
 REAL                                  :: PMP,XIJ,YIJ,XF,YF
 REAL                                  :: G,W,GMIN,GMAX
 REAL                                  :: WX(4),WY(4)
 REAL                                  :: XPTS(MO),YPTS(MO)
 REAL,               ALLOCATABLE,SAVE  :: RLATX(:),RLONX(:),WXY(:,:,:)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 IRET=0
 MCON=IPOPT(1)
 MP=IPOPT(2)
 IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
 IF(MP.LT.0.OR.MP.GT.100) IRET=32
 PMP=MP*0.01
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL CHECK_GRIDS1(IGDTNUMI,IGDTMPLI,IGDTLENI, &
                   IGDTNUMO,IGDTMPLO,IGDTLENO, &
                   SAME_GRIDI,SAME_GRIDO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SAVE OR SKIP WEIGHT COMPUTATION
 IF(IRET.EQ.0.AND.(IGDTNUMO.LT.0.OR..NOT.SAME_GRIDI.OR..NOT.SAME_GRIDO))THEN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
   IF(IGDTNUMO.GE.0) THEN
     CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO)
     IF(NO.EQ.0) IRET=3
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOCATE INPUT POINTS
   CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,NO,FILL,XPTS,YPTS,RLON,RLAT,NV)
   IF(IRET.EQ.0.AND.NV.EQ.0) IRET=2
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  ALLOCATE AND SAVE GRID DATA
   IF(NOX.NE.NO) THEN
     IF(NOX.GE.0) DEALLOCATE(RLATX,RLONX,NC,NXY,WXY)
     ALLOCATE(RLATX(NO),RLONX(NO),NC(NO),NXY(4,4,NO),WXY(4,4,NO))
     NOX=NO
   ENDIF
   IRETX=IRET
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE WEIGHTS
   IF(IRET.EQ.0) THEN
     CALL IJKGDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IJKGDSA)
!$OMP PARALLEL DO PRIVATE(N,XIJ,YIJ,IJX,IJY,XF,YF,J,I,WX,WY) SCHEDULE(STATIC)
     DO N=1,NO
       RLONX(N)=RLON(N)
       RLATX(N)=RLAT(N)
       XIJ=XPTS(N)
       YIJ=YPTS(N)
       IF(XIJ.NE.FILL.AND.YIJ.NE.FILL) THEN
         IJX(1:4)=FLOOR(XIJ-1)+(/0,1,2,3/)
         IJY(1:4)=FLOOR(YIJ-1)+(/0,1,2,3/)
         XF=XIJ-IJX(2)
         YF=YIJ-IJY(2)
         DO J=1,4
           DO I=1,4
             NXY(I,J,N)=IJKGDS1(IJX(I),IJY(J),IJKGDSA)
           ENDDO
         ENDDO
         IF(MINVAL(NXY(1:4,1:4,N)).GT.0) THEN
!  BICUBIC WHERE 16-POINT STENCIL IS AVAILABLE
           NC(N)=1
           WX(1)=XF*(1-XF)*(2-XF)/(-6.)
           WX(2)=(XF+1)*(1-XF)*(2-XF)/2.
           WX(3)=(XF+1)*XF*(2-XF)/2.
           WX(4)=(XF+1)*XF*(1-XF)/(-6.)
           WY(1)=YF*(1-YF)*(2-YF)/(-6.)
           WY(2)=(YF+1)*(1-YF)*(2-YF)/2.
           WY(3)=(YF+1)*YF*(2-YF)/2.
           WY(4)=(YF+1)*YF*(1-YF)/(-6.)
         ELSE
!  BILINEAR ELSEWHERE NEAR THE EDGE OF THE GRID
           NC(N)=2
           WX(1)=0
           WX(2)=(1-XF)
           WX(3)=XF
           WX(4)=0
           WY(1)=0
           WY(2)=(1-YF)
           WY(3)=YF
           WY(4)=0
         ENDIF
         DO J=1,4
           DO I=1,4
             WXY(I,J,N)=WX(I)*WY(J)
           ENDDO
         ENDDO
       ELSE
         NC(N)=0
       ENDIF
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE OVER ALL FIELDS
 IF(IRET.EQ.0.AND.IRETX.EQ.0) THEN
   IF(IGDTNUMO.GE.0) THEN
     NO=NOX
     DO N=1,NO
       RLON(N)=RLONX(N)
       RLAT(N)=RLATX(N)
     ENDDO
   ENDIF
!$OMP PARALLEL DO PRIVATE(NK,K,N,G,W,GMIN,GMAX,J,I) SCHEDULE(STATIC)
   DO NK=1,NO*KM
     K=(NK-1)/NO+1
     N=NK-NO*(K-1)
     IF(NC(N).GT.0) THEN
       G=0
       W=0
       IF(MCON.GT.0) GMIN=HUGE(GMIN)
       IF(MCON.GT.0) GMAX=-HUGE(GMAX)
       DO J=NC(N),5-NC(N)
         DO I=NC(N),5-NC(N)
           IF(NXY(I,J,N).GT.0)THEN
             IF(IBI(K).EQ.0.OR.LI(NXY(I,J,N),K))THEN
               G=G+WXY(I,J,N)*GI(NXY(I,J,N),K)
               W=W+WXY(I,J,N)
               IF(MCON.GT.0) GMIN=MIN(GMIN,GI(NXY(I,J,N),K))
               IF(MCON.GT.0) GMAX=MAX(GMAX,GI(NXY(I,J,N),K))
             ENDIF
           ENDIF
         ENDDO
       ENDDO
       LO(N,K)=W.GE.PMP
       IF(LO(N,K)) THEN
         GO(N,K)=G/W
         IF(MCON.GT.0) GO(N,K)=MIN(MAX(GO(N,K),GMIN),GMAX)
       ELSE
         GO(N,K)=0.
       ENDIF
     ELSE
       LO(N,K)=.FALSE.
       GO(N,K)=0.
     ENDIF
   ENDDO
   DO K=1,KM
     IBO(K)=IBI(K)
     IF(.NOT.ALL(LO(1:NO,K))) IBO(K)=1
   ENDDO
   IF(IGDTNUMO.EQ.0) CALL POLFIXS(NO,MO,KM,RLAT,IBO,LO,GO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ELSE
   IF(IRET.EQ.0) IRET=IRETX
   IF(IGDTNUMO.GE.0) NO=0
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATES1
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE CHECK_GRIDS1(IGDTNUMI,IGDTMPLI,IGDTLENI, &
                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
                         SAME_GRIDI, SAME_GRIDO)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  CHECK_GRIDS1   CHECK GRID INFORMATION
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: DETERMINE WHETHER THE INPUT OR OUTPUT GRID SPECS
!           HAVE CHANGED.
!
! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:  CALL CHECK_GRIDS1(IGDTNUMI,IGDTMPLI,IGDTLENI,IGDTNUMO,IGDTMPLO, &
!                           IGDTLENO, SAME_GRIDI, SAME_GRIDO)
!   INPUT ARGUMENT LIST:
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!
!   OUTPUT ARGUMENT LIST:
!     SAME_GRIDI  - WHEN TRUE, THE INPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!     SAME_GRIDO  - WHEN TRUE, THE OUTPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,        INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,        INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,        INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
!
 INTEGER, SAVE                 :: IGDTNUMI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLI_SAVE(1000)=-9999
 INTEGER, SAVE                 :: IGDTNUMO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLO_SAVE(1000)=-9999
!
 LOGICAL,        INTENT(  OUT) :: SAME_GRIDI, SAME_GRIDO
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SAME_GRIDI=.FALSE.
 IF(IGDTNUMI==IGDTNUMI_SAVE)THEN
   IF(IGDTLENI==IGDTLENI_SAVE)THEN
     IF(ALL(IGDTMPLI==IGDTMPLI_SAVE(1:IGDTLENI)))THEN
       SAME_GRIDI=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMI_SAVE=IGDTNUMI
 IGDTLENI_SAVE=IGDTLENI
 IGDTMPLI_SAVE(1:IGDTLENI)=IGDTMPLI
 IGDTMPLI_SAVE(IGDTLENI+1:1000)=-9999
!
 SAME_GRIDO=.FALSE.
 IF(IGDTNUMO==IGDTNUMO_SAVE)THEN
   IF(IGDTLENO==IGDTLENO_SAVE)THEN
     IF(ALL(IGDTMPLO==IGDTMPLO_SAVE(1:IGDTLENO)))THEN
       SAME_GRIDO=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMO_SAVE=IGDTNUMO
 IGDTLENO_SAVE=IGDTLENO
 IGDTMPLO_SAVE(1:IGDTLENO)=IGDTMPLO
 IGDTMPLO_SAVE(IGDTLENO+1:1000)=-9999
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE CHECK_GRIDS1


!----------------------------------------------------------------------------- best with 100 columns

!> shape, mapping, and quadrature
!> NOTE: initSMQ() must be called to have full functionalists
module modSMQ
  public

  ! constants
  integer,private,parameter::DIMS=3 !< dimensions

  double precision,parameter::TET_C(4,4)=reshape(& !< TET shape function factors
  &  [-1d0,-1d0,-1d0, 1d0,&
  &    1d0, 0d0, 0d0, 0d0,&
  &    0d0, 1d0, 0d0, 0d0,&
  &    0d0, 0d0, 1d0, 0d0],[4,4])
  double precision,parameter,public::TET_QP(DIMS,1)=reshape(& !< TET quadrature points
  &  [0.25d0,0.25d0,0.25d0],[DIMS,1])
  double precision,parameter,public::TET_QW(1)=& !< TET quadrature weights
  &  [1.66666666666666666d-1]

  double precision,parameter::TET10_C(10,10)=reshape(& !< TET10 shape function factors
  &  [ 2d0, 2d0, 2d0, 4d0, 4d0, 4d0,-3d0,-3d0,-3d0, 1d0,&
  &    2d0, 0d0, 0d0, 0d0, 0d0, 0d0,-1d0, 0d0, 0d0, 0d0,&
  &    0d0, 2d0, 0d0, 0d0, 0d0, 0d0, 0d0,-1d0, 0d0, 0d0,&
  &    0d0, 0d0, 2d0, 0d0, 0d0, 0d0, 0d0, 0d0,-1d0, 0d0,&
  &   -4d0, 0d0, 0d0,-4d0,-4d0, 0d0, 4d0, 0d0, 0d0, 0d0,&
  &    0d0, 0d0, 0d0, 4d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,&
  &    0d0,-4d0, 0d0,-4d0, 0d0,-4d0, 0d0, 4d0, 0d0, 0d0,&
  &    0d0, 0d0,-4d0, 0d0,-4d0,-4d0, 0d0, 0d0, 4d0, 0d0,&
  &    0d0, 0d0, 0d0, 0d0, 0d0, 4d0, 0d0, 0d0, 0d0, 0d0,&
  &    0d0, 0d0, 0d0, 0d0, 4d0, 0d0, 0d0, 0d0, 0d0, 0d0],[10,10])
  double precision,parameter,public::TET10_QP(DIMS,4)=reshape(& !< TET10 quadrature points
  &  [5.85410196624968515d-1,1.38196601125010504d-1,1.38196601125010504d-1,&
  &   1.38196601125010504d-1,5.85410196624968515d-1,1.38196601125010504d-1,&
  &   1.38196601125010504d-1,1.38196601125010504d-1,5.85410196624968515d-1,&
  &   1.38196601125010504d-1,1.38196601125010504d-1,1.38196601125010504d-1],[DIMS,4])
  double precision,parameter,public::TET10_QW(4)=& !< TET10 quadrature weights
  &  [4.16666666666666667d-2,4.16666666666666667d-2,4.16666666666666667d-2,4.16666666666666667d-2]

  double precision,parameter::TRI_C(3,3)=reshape(& !< TRI shape function factors
  &  [-1d0,-1d0, 1d0,&
  &    1d0, 0d0, 0d0,&
  &    0d0, 1d0, 0d0],[3,3])
  double precision,parameter,public::TRI_QP(2,1)=reshape(& !< TRI quadrature points
  &  [1d0/3d0,1d0/3d0],[2,1])
  double precision,parameter,public::TRI_QW(1)=& !<TRI quadrature weights
  &  [0.5d0]

  double precision,parameter::TRI6_C(6,6)=reshape(& !< TRI6 shape function factors
  &  [ 2d0, 2d0, 4d0,-3d0,-3d0, 1d0,&
  &    2d0, 0d0, 0d0,-1d0, 0d0, 0d0,&
  &    0d0, 2d0, 0d0, 0d0,-1d0, 0d0,&
  &   -4d0, 0d0,-4d0, 4d0, 0d0, 0d0,&
  &    0d0, 0d0, 4d0, 0d0, 0d0, 0d0,&
  &    0d0,-4d0,-4d0, 0d0, 4d0, 0d0],[6,6])
  double precision,parameter,public::TRI6_QP(2,3)=reshape(& !< TRI6 quadrature points
  &  [1d0/6d0,1d0/6d0,2d0/3d0,1d0/6d0,1d0/6d0,2d0/3d0],[2,3])
  double precision,parameter,public::TRI6_QW(3)=& !<TRI6 quadrature weights
  &  [1d0/6d0,1d0/6d0,1d0/6d0]

  ! to be used as constant once initSMQ() is called
  double precision,public::TET_SHAPE_QP(4,1) !< TET shape function at QP
  double precision,public::TET_GRAD_QP(DIMS,4,1) !< TET shape grad at QP
  double precision,public::TET10_SHAPE_QP(10,4) !< TET10 shape function at QP
  double precision,public::TET10_GRAD_QP(DIMS,10,4) !< TET10 shape grad at QP
  double precision,public::TRI_SHAPE_QP(3,1) !< TRI shape function at QP
  double precision,public::TRI_GRAD_QP(2,3,1) !< TRI shape grad at QP
  double precision,public::TRI6_SHAPE_QP(6,3) !< TRI6 shape function at QP
  double precision,public::TRI6_GRAD_QP(2,6,3) !< TRI6 shape grad at QP

contains

  !> initialize the SMQ module
  subroutine initSMQ
    do i=1,1
      TET_SHAPE_QP(:,i)=shapeTet(TET_QP(:,i))
      TET_GRAD_QP(:,:,i)=gradShapeTet(TET_QP(:,i))
    end do
    do i=1,4
      TET10_SHAPE_QP(:,i)=shapeTet10(TET10_QP(:,i))
      TET10_GRAD_QP(:,:,i)=gradShapeTet10(TET10_QP(:,i))
    end do
    do i=1,1
      TRI_SHAPE_QP(:,i)=shapeTri(TRI_QP(:,i))
      TRI_GRAD_QP(:,:,i)=gradShapeTri(TRI_QP(:,i))
    end do
    do i=1,3
      TRI6_SHAPE_QP(:,i)=shapeTri6(TRI6_QP(:,i))
      TRI6_GRAD_QP(:,:,i)=gradShapeTri6(TRI6_QP(:,i))
    end do
  end subroutine

  !> shape function of reference TET
  pure function shapeTet(xx)
    double precision,intent(in)::xx(DIMS) !< test location in the reference coordinate
    double precision::shapeTet(4) !< value of the 4 shape functions
    double precision::terms(4)

    terms(:)=[xx(1),xx(2),xx(3),1d0]
    shapeTet=matmul(terms,TET_C)
  end function

  !> shape function gradient of reference TET
  pure function gradShapeTet(xx)
    double precision,intent(in),optional::xx(DIMS) !< test location in the reference coordinate
    double precision::gradShapeTet(DIMS,4) !< gradient of the 4 shape functions
    double precision::terms(DIMS,4)

    terms(1,:)=[1d0,0d0,0d0,0d0]
    terms(2,:)=[0d0,1d0,0d0,0d0]
    terms(3,:)=[0d0,0d0,1d0,0d0]
    gradShapeTet=matmul(terms,TET_C)
    if(present(xx))then
    end if
  end function

  !> Jacobian matrix of the iso-parametric map for TET
  pure function mapJTet(xN,xx)
    double precision,intent(in)::xN(DIMS,4) !< the location of the 4 nodes
    double precision,intent(in)::xx(DIMS) !< location in reference coordinate where J is evaluated
    double precision::mapJTet(DIMS,DIMS) !< the Jacobian matrix
    double precision::grad(DIMS,4)

    grad=gradShapeTet(xx)
    mapJTet=matmul(grad,transpose(xN))
  end function

  !> shape function of reference TET10
  pure function shapeTet10(xx)
    double precision,intent(in)::xx(DIMS) !< test location in the reference coordinate
    double precision::shapeTet10(10) !< value of the 10 shape functions
    double precision::terms(10)

    terms(:)=[xx(1)**2,xx(2)**2,xx(3)**2,xx(1)*xx(2),xx(1)*xx(3),xx(2)*xx(3),xx(1),xx(2),xx(3),1d0]
    shapeTet10=matmul(terms,TET10_C)
  end function

  !> shape function gradient of reference TET10
  pure function gradShapeTet10(xx)
    double precision,intent(in)::xx(DIMS) !< test location in the reference coordinate
    double precision::gradShapeTet10(DIMS,10) !< gradient of the 10 shape functions
    double precision::terms(DIMS,10)

    terms(1,:)=[2*xx(1),0d0,0d0,xx(2),xx(3),0d0,1d0,0d0,0d0,0d0]
    terms(2,:)=[0d0,2*xx(2),0d0,xx(1),0d0,xx(3),0d0,1d0,0d0,0d0]
    terms(3,:)=[0d0,0d0,2*xx(3),0d0,xx(1),xx(2),0d0,0d0,1d0,0d0]
    gradShapeTet10=matmul(terms,TET10_C)
  end function

  !> Jacobian matrix of the iso-parametric map for TET10
  pure function mapJTet10(xN,xx)
    double precision,intent(in)::xN(DIMS,10) !< the location of the 10 nodes
    double precision,intent(in)::xx(DIMS) !< location in reference coordinate where J is evaluated
    double precision::mapJTet10(DIMS,DIMS) !< the Jacobian matrix
    double precision::grad(DIMS,10)

    grad=gradShapeTet10(xx)
    mapJTet10=matmul(grad,transpose(xN))
  end function

  !> shape function of reference TRI
  pure function shapeTri(xx)
    double precision,intent(in)::xx(2) !< test location in the reference coordinate
    double precision::shapeTri(3) !< value of the 3 shape functions
    double precision::terms(3)

    terms(:)=[xx(1),xx(2),1d0]
    shapeTri=matmul(terms,TRI_C)
  end function

  !> shape function gradient of reference TRI
  pure function gradShapeTri(xx)
    double precision,intent(in),optional::xx(2) !< test location in the reference coordinate
    double precision::gradShapeTri(2,3) !< gradient of the 3 shape functions
    double precision::terms(2,3)

    terms(1,:)=[1d0,0d0,0d0]
    terms(2,:)=[0d0,1d0,0d0]
    gradShapeTri=matmul(terms,TRI_C)
    if(present(xx))then
    end if
  end function

  !> Jacobian matrix of the iso-parametric map for TRI (2 xx components by 3 x components)
  pure function mapJTri(xN,xx)
    double precision,intent(in)::xN(DIMS,3) !< the location of the 3 nodes
    double precision,intent(in)::xx(2) !< location in reference coordinate where J is evaluated
    double precision::mapJTri(2,DIMS) !< the Jacobian matrix
    double precision::grad(2,3)

    grad=gradShapeTri(xx)
    mapJTri=matmul(grad,transpose(xN))
  end function

  !> shape function of reference TRI6
  pure function shapeTri6(xx)
    double precision,intent(in)::xx(2) !< test location in the reference coordinate
    double precision::shapeTri6(6) !< value of the 6 shape functions
    double precision::terms(6)

    terms(:)=[xx(1)**2,xx(2)**2,xx(1)*xx(2),xx(1),xx(2),1d0]
    shapeTri6=matmul(terms,TRI6_C)
  end function

  !> shape function gradient of reference TRI6
  pure function gradShapeTri6(xx)
    double precision,intent(in)::xx(2) !< test location in the reference coordinate
    double precision::gradShapeTri6(2,6) !< gradient of the 6 shape functions
    double precision::terms(2,6)

    terms(1,:)=[2*xx(1),0d0,xx(2),1d0,0d0,0d0]
    terms(2,:)=[0d0,2*xx(2),xx(1),0d0,1d0,0d0]
    gradShapeTri6=matmul(terms,TRI6_C)
  end function

  !> Jacobian matrix of the iso-parametric map for TRI6 (2 xx components by 3 x components)
  pure function mapJTri6(xN,xx)
    double precision,intent(in)::xN(DIMS,6) !< the location of the 6 nodes
    double precision,intent(in)::xx(2) !< location in reference coordinate where J is evaluated
    double precision::mapJTri6(2,DIMS) !< the Jacobian matrix
    double precision::grad(2,6)

    grad=gradShapeTri6(xx)
    mapJTri6=matmul(grad,transpose(xN))
  end function

end module


! Solves for the new solution vector
!
! Steady state - T = [K]^-1 * F
!
! Input: isotope - fissionble isotope contributing to the delayed precursors
!        delay_group - delayed neutron precursor grop
!        n - current node index
!        nl_iter - nonlinear iteration index
!
! Output:
!
!
subroutine solve_precursor_ss(isotope, delay_group, n, nl_iter )

    USE flags_M
    USE material_info_M
    USE mesh_info_M
    USE time_info_M
    USE global_parameters_M
    USE solution_vectors_M
    USE element_matrices_M
    use Mod_SetupOutputFiles

    implicit none

!---Dummy
    integer,intent(in) :: isotope
    integer,intent(in) :: delay_group
    integer,intent(in) :: nl_iter
    integer,intent(in) :: n ! current node

!---Local
    real(dp), dimension(3)   :: rhs_final_vec
    real(dp), dimension(3,3) :: inverse_matrix
    integer :: length, i, j, f,g

    !---Inversion routine parameters
    integer :: lda, info, lwork
    integer,  dimension(3) :: ipiv
    real(dp), dimension(3) :: work

    length = 3
!---Initialize
    ipiv =  0
    work =  0.0
    lda =   length
    lwork = length

!---PRECURSOR SOLVE
    rhs_final_vec = 0
    !---Setup G matrix to be inverted later on
    do i = 1, nodes_per_elem
        do j = 1, nodes_per_elem
            inverse_matrix(i,j) = elem_matrix_G(i,j)
        end do
    end do

    !---Compute RHS vector
    do i = 1, nodes_per_elem
        rhs_final_vec(i) = elem_vec_q_final(isotope,delay_group,i) + elem_vec_w_left_face(i)
    end do

    !---Factorize G matrix matrix
    call dgetrf ( length, length, inverse_matrix, lda, ipiv, info )
    !---Compute the inverse matrix.
    call dgetri ( length, inverse_matrix, lda, ipiv, work, lwork, info )

    !---CALCULATE SOLUTION for a given element
    precursor_soln_new(isotope,delay_group,n,:) = matmul(inverse_matrix,rhs_final_vec)

    do i = 1, nodes_per_elem

        if( precursor_soln_new(isotope,delay_group,n,i) < 1E-16_dp) then
            precursor_soln_new(isotope,delay_group,n,i) = 0.0_dp
    !        write(outfile_unit, fmt='(a,I6,a,I6)'), 'Negative precursor conc. &
    !                        calculated at node: ', n, 'element: ',i
        end if
    end do

    !----------------------------------------------------
    if (DEBUG .eqv. .TRUE.) then
        !---Write out
        write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I3)'),'RHS final vector | element --> ', n
        do j=1,nodes_per_elem
              write(outfile_unit,fmt='(12es14.3)') rhs_final_vec(j)
        end do
        !---Write out inverse matrix
        write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I3)'),'inverse G precursor matrix matrix | element --> ',n
        do j=1,nodes_per_elem
               write(outfile_unit,fmt='(12es14.3)') &
                    ( inverse_matrix(j,i) ,i=1,nodes_per_elem )
        end do

write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I3,a,1I6,a,1I3)'),&
            'Previous Solution | element --> ', n, ' Isotope ',isotope,&
             ' Delayed Group ',delay_group
            do j=1,nodes_per_elem
                write(outfile_unit,fmt='(a,1I6,12es14.3)'), 'Node --> ', n-1+j,&
                  precursor_soln_prev(isotope,delay_group,n,j)

        end do

        write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I3,a,1I6,a,1I3)'),&
            'Solution | element --> ', n, ' Isotope ',isotope,&
             ' Delayed Group ',delay_group
            do j=1,nodes_per_elem
                write(outfile_unit,fmt='(a,1I6,12es14.3)'), 'Node --> ', n-1+j,&
                  precursor_soln_new(isotope,delay_group,n,j)

        end do

        write(outfile_unit,fmt='(a)'), '********************************'
    end if

end subroutine solve_precursor_ss


*> \brief \b SCABS1
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL FUNCTION SCABS1(Z)
*
*       .. Scalar Arguments ..
*       COMPLEX Z
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SCABS1 computes |Re(.)| + |Im(.)| of a complex number
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2015
*
*> \ingroup single_blas_level1
*
*  =====================================================================
      REAL FUNCTION SCABS1(Z)
*
*  -- Reference BLAS level1 routine (version 3.6.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2015
*
*     .. Scalar Arguments ..
      COMPLEX Z
*     ..
*
*  =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC ABS,AIMAG,REAL
*     ..
      SCABS1 = ABS(REAL(Z)) + ABS(AIMAG(Z))
      RETURN
      END


MODULE environmental_routines
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),ALLOCATABLE::table1(:,:),table2(:,:),table3(:,:),table4(:,:)
 REAL(iwp),PARAMETER::pi=3.141592653589793238_iwp,zero=0.0_iwp
 REAL(iwp)::t_m1,t_p1,delay_1,t_m2,t_p2,delay_2,delay_3
 REAL(iwp)::wl,ts,ao,tauo,ce,e1,e2,e3,e4,e5
 REAL(iwp)::aa,bb,Io
 PRIVATE::iwp
 PRIVATE::t_m1,t_p1,delay_1,t_m2,t_p2,delay_2
 PRIVATE::wl,ts,ao,tauo,ce,e1,e2,e3,e4,e5
 PRIVATE::aa,bb,Io
 PUBLIC::pi,zero
 PUBLIC::table1,table2,table3,table4
CONTAINS
!
!-------------------------------------------------------------------------
! Counting of time
!-------------------------------------------------------------------------
SUBROUTINE day_of_year(jd,d)
 IMPLICIT NONE
 REAL(iwp),INTENT(in)::jd
 REAL(iwp),INTENT(out)::d
 INTEGER::year,month,jdate,jhour
 REAL(iwp)::jd_i,day
 CALL civil_date(jd,year,month,day)
 jdate=(year-1)*10000+1200+31
 jhour=2400
 CALL julian_day(jdate,jhour,jd_i)
 d=jd-jd_i
END SUBROUTINE day_of_year
!
SUBROUTINE civil_date(jd,year,month,day)
 IMPLICIT NONE
 REAL(iwp),INTENT(IN)::jd
 INTEGER,INTENT(OUT)::year,month
 REAL(iwp),INTENT(OUT)::day
 INTEGER::z,w,a,b,c,d,e,f
 REAL(iwp)::q
 q=jd+0.5
 z=INT(q)
 w=INT((jd-1867216.25)/36524.25)
 a=z+1+w-INT(w/4)
 b=a+1524
 c=INT((b-122.1)/365.25)
 d=INT(c*365.25)
 e=INT((b-d)/30.6001)
 f=INT(e*30.6001)
 day=b-d-f+(q-z)
 IF(e<14) THEN
   month=e-1
 ELSE
   month=e-13
 END IF
 IF(month>2) THEN
   year=c-4716
 ELSE
   year=c-4715
 END IF
END SUBROUTINE civil_date
!
SUBROUTINE julian_day(jdate,jhour,jd)
 IMPLICIT NONE
 INTEGER::jdate,jhour,y,m,d,a,b,c,e,f
 REAL(iwp)::jd,hour,minute
 y=INT(jdate/10000)
 m=INT((jdate-y*10000)/100)
 d=INT(jdate-y*10000-m*100)
 hour=FLOAT(jhour/100)
 minute=jhour-hour*100
 IF(m<3) THEN
   y=y-1
   m=m+12
 END IF
 a=INT(y/100)
 b=INT(a/4)
 c=2-a+b
 e=INT(365.25*(y+4716))
 f=INT(30.6001*(m+1))
 jd=FLOAT(c+d+e+f)-1524.5+hour/24.+minute/1440.
RETURN
END SUBROUTINE julian_day
!
FUNCTION date_hour(jd) RESULT(char_num)
 IMPLICIT NONE
 INTEGER::jdate,jhour,yyyy,mm
 REAL(iwp),INTENT(in)::jd
 REAL(iwp)::ut,minutes,seconds,dd
 CHARACTER(len=14)::char_num
 CHARACTER(len=8)::char_idate
 CHARACTER(len=6)::char_ihour
 ut=jd+0.5_iwp-AINT(jd+0.5_iwp)+1e-6
 CALL civil_date(jd,yyyy,mm,dd)
 jdate=yyyy*10000+mm*100+INT(dd)
 minutes=(ut*24_iwp-INT(ut*24_iwp))*60_iwp
 seconds=(minutes-INT(minutes))*60_iwp
 jhour=INT(ut*24_iwp)*10000+INT(minutes)*100+INT(seconds)
 WRITE(char_idate,'(i8)')jdate
 WRITE(char_ihour,'(i6)')jhour
 char_ihour=ADJUSTL(char_ihour)
 IF(jhour>=10000.and.jhour<100000)char_ihour='0'//TRIM(char_ihour)
 IF(jhour>=1000.and.jhour<10000)char_ihour='00'//TRIM(char_ihour)
 IF(jhour>=100.and.jhour<1000)char_ihour='000'//TRIM(char_ihour)
 IF(jhour>=10.and.jhour<100.)char_ihour='0000'//TRIM(char_ihour)
 IF(jhour<10)char_ihour='00000'//TRIM(char_ihour)
 char_num=char_idate//char_ihour
END FUNCTION date_hour
!
!-------------------------------------------------------------------------
! Reservoir temperature boundary conditions
!
!------------------Glossary of input variables----------------------------
!
! Scalar reals:
! wl               reservoir level
! ts               yearly mean water temperature at the surface
! ao               amplitude of annual variation at the surface
! tauo             day of maximumwater temperature at the surface
! tb               yearly mean water temperature at the bottom
! c1 to c5         Bofang's formula parameters
!-------------------------------------------------------------------------
SUBROUTINE reservoir_parameters
  IMPLICIT NONE
  READ(10,*)wl,ts,ao,tauo,ce,e1,e2,e3,e4,e5
  WRITE(11,'(/a,E11.4)')"Reservoir level                                = ",wl
  WRITE(11,'(a,E11.4)')"Yearly mean water temperature at the surface   = ",ts
  WRITE(11,'(a,E11.4)')"Amplitude of annual variation at the surface   = ",ao
  WRITE(11,'(a,E11.4)')"Day of maximumwater air temperature            = ",tauo
  WRITE(11,'(a,E11.4)')"Bofang's formula parameter c                   = ",ce
  WRITE(11,'(a,E11.4)')"Bofang's formula parameter e1                  = ",e1
  WRITE(11,'(a,E11.4)')"Bofang's formula parameter e2                  = ",e2
  WRITE(11,'(a,E11.4)')"Bofang's formula parameter e3                  = ",e3
  WRITE(11,'(a,E11.4)')"Bofang's formula parameter e4                  = ",e4
  WRITE(11,'(a,E11.4)')"Bofang's formula parameter e5                  = ",e5
END SUBROUTINE reservoir_parameters
!
FUNCTION reservoir_temperature(z,d)RESULT(t)
 IMPLICIT NONE
 REAL(iwp),INTENT(in)::z,d
 REAL(iwp)::t,y,tm,a,t0
 y=wl-z
 IF(y<zero) y=zero
 tm=ce+(ts-ce)*EXP(-e1*y)
 a=-ao*EXP(-e2*y)
 t0=(e3-e4*EXP(-e5*y))*365.0/12.0+tauo
 t=tm+a*COS(2*pi/365.0*(d-t0))
END FUNCTION reservoir_temperature
!
!-------------------------------------------------------------------------
! Other temperature boundary conditions
!
!------------------Glossary of input variables----------------------------
!
! Scalar integer:
! jdate            date in yyyymmdd format
! jhour            time in hhmm format
!
! Scalar real:
! temp             temperature
!-------------------------------------------------------------------------
SUBROUTINE temp_table(ifile)
  IMPLICIT NONE
  INTEGER::i,icont,io,jdate,jhour
  REAL(iwp)::temp,jd
  CHARACTER(len=100),INTENT(in)::ifile
  OPEN(20,FILE=ifile,STATUS='OLD')
  icont=0
  DO
    READ(20,*,IOSTAT=io)jdate,jhour,temp
    IF(io<0)THEN
      EXIT
    ELSE
      icont=icont+1
    END IF
  END DO
  ALLOCATE(table4(icont,2))
  REWIND 20
  DO i=1,icont
    READ(20,*,IOSTAT=io)jdate,jhour,temp
    CALL Julian_Day(jdate,jhour,jd)
    table4(i,1)=jd
    table4(i,2)=temp
  END DO
END SUBROUTINE temp_table
!
!-------------------------------------------------------------------------
! Solar radiation boundary conditions
!-------------------------------------------------------------------------
SUBROUTINE radiation_parameters(utemp)
 CHARACTER(len=1),INTENT(in)::utemp
 WRITE(11,'(/a)')"Exponential function"
 READ(10,*)aa,bb
 WRITE(11,'(a,E11.4,a,E11.4,3a)')                                        &
 "Ib/cos Z = Io exp(",aa,"+",bb," cos Z) in J/(",utemp," m2)"
 SELECT CASE(utemp)
 CASE("d")
   Io=1367*86400.0_iwp
 CASE("h")
   Io=1367*3600.0_iwp
 CASE("s")
   Io=1367
 END SELECT
END SUBROUTINE radiation_parameters
!
FUNCTION exponential_function(cos_z)RESULT(ih)
 IMPLICIT NONE
 REAL(iwp),INTENT(in)::cos_z
 REAL(iwp)::ih
 ih=Io*EXP(aa+bb*cos_z)
END FUNCTION exponential_function
!
SUBROUTINE rad_table(ifile)
  IMPLICIT NONE
  INTEGER::i,icont,io,jdate,jhour
  REAL(iwp)::ibeam,idiffuse,jd
  CHARACTER(len=100),INTENT(in)::ifile
  OPEN(20,FILE=ifile,STATUS='OLD')
  icont=0
  DO
    READ(20,*,IOSTAT=io)jdate,jhour,ibeam,idiffuse
    IF(io<0)THEN
      EXIT
    ELSE
      icont=icont+1
    END IF
  END DO
  ALLOCATE(table3(icont,3))
  REWIND 20
  DO i=1,icont
    READ(20,*,IOSTAT=io)jdate,jhour,ibeam,idiffuse
    CALL julian_day(jdate,jhour,jd)
    table3(i,1)=jd
    table3(i,2)=ibeam
    table3(i,3)=idiffuse
  END DO
END SUBROUTINE rad_table
!
SUBROUTINE solar_position(d,fi,delta,omega,cos_z)
 IMPLICIT NONE
 REAL(iwp),INTENT(in)::d,fi
 REAL(iwp)::dr,tz,cos_z,ut
 REAL(iwp),INTENT(out)::delta,omega
 ut=d-AINT(d)
 dr=pi/180.0_iwp
!----day angle
 tz=2.0_iwp*pi*d/365.0_iwp
!----solar declination
 delta=rdecl(tz)
!----solar hour angle
 omega=-15.0*(ut*24.0-12.)*dr
!---cosine of solar zenith angle
 cos_z=SIN(fi)*SIN(delta)+COS(fi)*COS(delta)*COS(omega)
 IF(cos_z<zero)cos_z=0.0
END SUBROUTINE solar_position
!
FUNCTION incident_angle(delta,omega,phi,yy,beta)RESULT(cos_alpha)
 IMPLICIT NONE
 REAL(iwp),INTENT(IN)::delta,omega,phi,yy,beta
 REAL(iwp)::aa,bb,cc,cos_alpha
 aa=COS(yy)*SIN(phi)-SIN(yy)*COS(phi)*COS(beta)
 bb=COS(yy)*COS(phi)+SIN(yy)*SIN(phi)*COS(beta)
 cc=SIN(yy)*SIN(beta)
 cos_alpha=(aa*SIN(delta)+bb*COS(omega)*COS(delta)-cc*SIN(omega)*        &
   COS(delta))
 IF(cos_alpha<zero) cos_alpha=zero
END FUNCTION incident_angle
!
SUBROUTINE Kumar_model(d,cos_z,ibeam,idiffuse)
 IMPLICIT NONE
 REAL(iwp),INTENT(in)::d,cos_z
 REAL(iwp)::epsilon,G0,m,Tb,Td
 REAL(iwp),INTENT(out)::ibeam,idiffuse
!----Sun-Earth distance
!----correction factor
 epsilon=1.0+0.0344*COS(2.0*pi/365.25*d-0.0488869)
!----extraterrestrial irradiance
 G0=epsilon*1367.0
!---optical air mass
 m=SQRT(1229.0+(614.0*cos_z)*(614.0*cos_z))-614.0*cos_z
!---atmosferic atenuation
 Tb=0.56*(EXP(-0.65*m)+EXP(-0.095*m))
!
 IF(cos_z < zero) THEN
   ibeam=zero
 ELSE
   ibeam=G0*Tb
 END IF
 Td=0.271-0.294*Tb
 idiffuse=1367.0*Td*cos_z
 RETURN
END SUBROUTINE Kumar_model
!
FUNCTION rdecl(tz)RESULT(decl)
 IMPLICIT NONE
 REAL(iwp),INTENT(in)::tz
 REAL(iwp)::decl,sintz,costz,sin2tz,cos2tz,sin3tz,cos3tz
  sintz = SIN(tz)
  costz = COS(tz)
  sin2tz = 2.*sintz*costz
  cos2tz = costz*costz-sintz*sintz
  sin3tz = sintz*cos2tz + costz*sin2tz
  cos3tz = costz*cos2tz - sintz*sin2tz
!---> declination in radians
  decl = 0.006918 - 0.399912*costz  + 0.070257*sintz   &
                  - 0.006758*cos2tz + 0.000907*sin2tz  &
                  - 0.002697*cos3tz + 0.001480*sin3tz
END FUNCTION rdecl
!
!-------------------------------------------------------------------------
! Convection boundary conditions
!
!------------------Glossary of input variables----------------------------
!
! Scalar integer:
! jdate            date in yyyymmdd format
! jhour            time in hhmm format
!
! Scalar real:
! t_m1             yearly mean temperature
! t_p1             amplitude of annual temperature variation
! delay_1          yearly temperature phase difference
! t_m2             yearly mean amplitude
! t_p2             amplitude of annual variation of the daily amplitude
! delay_2          yearly phase difference of the daily amplitude
! delay_3          daily temperature phase difference
! temp             temperature
! htco             heat convection coefficient
!-------------------------------------------------------------------------
SUBROUTINE air_parameters
  WRITE(11,'(/a)')"Harmonic function"
  READ(10,*)t_m1,t_p1,delay_1,t_m2,t_p2,delay_2,delay_3
  WRITE(11,'(a,E11.4)')"Yearly mean temperature                        = ",t_m1
  WRITE(11,'(a,E11.4)')"Amplitude of annual temperature variation      = ",t_p1
  WRITE(11,'(a,E11.4)')"Yearly temperature phase difference            = ",delay_1
  WRITE(11,'(a,E11.4)')"Yearly mean amplitude                          = ",t_m2
  WRITE(11,'(a,E11.4)')"Amplitude of the daily amplitude variation     = ",tp_2
  WRITE(11,'(a,E11.4)')"Yearly phase difference of the daily amplitude = ",delay_2
  WRITE(11,'(a,E11.4)')"Daily temperature phase differencee            = ",delay_3
END SUBROUTINE air_parameters
!
SUBROUTINE air_table1(ifile)
  IMPLICIT NONE
  INTEGER::i,icont,io,jdate,jhour
  REAL(iwp)::temp,jd,htco
  CHARACTER(len=100),INTENT(in)::ifile
  OPEN(20,FILE=ifile,STATUS='OLD')
  icont=0
  DO
    READ(20,*,IOSTAT=io)jdate,jhour,temp
    IF(io<0)THEN
      EXIT
    ELSE
      icont=icont+1
    END IF
  END DO
  ALLOCATE(table1(icont,3))
  REWIND 20
  DO i=1,icont
    READ(20,*,IOSTAT=io)jdate,jhour,temp,htco
    CALL Julian_Day(jdate,jhour,jd)
    table1(i,1)=jd
    table1(i,2)=temp
    table1(i,3)=htco
  END DO
END SUBROUTINE air_table1
!
SUBROUTINE air_table2(ifile)
  IMPLICIT NONE
  INTEGER::i,icont,io,jdate,jhour
  REAL(iwp)::temp,jd,htco
  CHARACTER(len=100),INTENT(in)::ifile
  OPEN(20,FILE=ifile,STATUS='OLD')
  icont=0
  DO
    READ(20,*,IOSTAT=io)jdate,jhour,temp
    IF(io<0)THEN
      EXIT
    ELSE
      icont=icont+1
    END IF
  END DO
  ALLOCATE(table2(icont,3))
  REWIND 20
  DO i=1,icont
    READ(20,*,IOSTAT=io)jdate,jhour,temp,htco
    CALL Julian_Day(jdate,jhour,jd)
    table2(i,1)=jd
    table2(i,2)=temp
    table2(i,3)=htco
  END DO
END SUBROUTINE air_table2
!
FUNCTION harmonic_function(d)RESULT(t_a)
 IMPLICIT NONE
 REAL(iwp),INTENT(in)::d
 REAL(iwp)::t_a,omega,t_0,t_b,t_e,t_p
 t_0=d
 omega=2.0_iwp*pi/(365.0_iwp)
 t_b=t_m1-t_p1*(COS(omega*(t_0-delay_1)))
!
 t_e=t_m2-t_p2*(COS(omega*(t_0-delay_2)))
!
 t_p=t_e/2.0_iwp
 omega=2.0_iwp*pi
 t_a=t_b-t_p*COS(omega*(t_0-delay_3))
END FUNCTION harmonic_function
!
!-------------------------------------------------------------------------
! Extract values from tables
!-------------------------------------------------------------------------
FUNCTION find_in_table(table,jd)RESULT(dd)
 IMPLICIT NONE
 INTEGER::i,n
 REAL(iwp),INTENT(in)::jd,table(:,:)
 REAL(iwp)::dd
 n=UBOUND(table,1)
 DO i=1,n
   IF(jd>table(i+1,1))cycle
   dd=table(i,2)+(table(i+1,2)-table(i,2))*(jd-table(i,1))/              &
      (table(i+1,1)-table(i,1))
   EXIT
 END DO
END FUNCTION find_in_table
!
FUNCTION find_in_table2(table,jd)RESULT(dd)
 IMPLICIT NONE
 INTEGER::i,n
 REAL(iwp),INTENT(in)::jd,table(:,:)
 REAL(iwp)::dd
 n=UBOUND(table,1)
 DO i=1,n
   IF(jd>table(i+1,1))cycle
   dd=table(i,3)+(table(i+1,3)-table(i,3))*(jd-table(i,1))/              &
      (table(i+1,1)-table(i,1))
   EXIT
 END DO
END FUNCTION find_in_table2
!
END MODULE environmental_routines


Program sobol_test
  Use mlf_sobol1111
  type(mlf_sobol1111_sampler) :: s
  integer, parameter :: l = 64
  real(8) :: X(l, 5)
  integer :: info, i
  info = s%init(5)
  Do i=1,l
    info = s%sample(X(i,:))
    PRINT *, REAL(X(i,:), KIND = 4)
  End Do
End


      subroutine periodic_compute_error(blockno, mx,my,mbc,meqn,
     &      dx,dy,xlower,ylower,t,q,error, soln)
      implicit none

      external f

      integer mx,my,mbc,meqn, blockno
      double precision dx, dy, xlower, ylower, t
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision error(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision soln(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

c      integer*8 cont, get_context

      integer example
      common /example_comm/ example

      double precision ubar, vbar
      common /comrp/ ubar,vbar

      integer i,j,m, k, l
      double precision xi, yj, xk, yk, a(3,3), q0

      a(1,1) = 1d0
      a(1,2) = 4d0
      a(1,3) = 1d0
      a(2,1) = 4d0
      a(2,2) = 16d0
      a(2,3) = 4d0
      a(3,1) = 1d0
      a(3,2) = 4d0
      a(3,3) = 1d0

c      cont = get_context()

      do j = 1-mbc,my+mbc
         do  i = 1-mbc,mx+mbc
            soln(i,j,1) = 0d0
         end do
      end do

c     # Assume a single field variable only
      do j = 1,my
         do i = 1,mx
c            xc = xlower + (i-0.5)*dx
c            yc = ylower + (j-0.5)*dy

            if (t .eq. 0) then
               soln(i,j,1) = q(i,j,1)
            else
               if (example .eq. 0) then
                  xi = xlower + (i-1d0)*dx
                  yj = ylower + (j-1d0)*dy
                  do k = 0,2
                     do l = 0,2
                        xk = xi + k*dx/2 - ubar*t
                        yk = yj + l*dy/2 - vbar*t
                        soln(i,j,1) = soln(i,j,1) +
     &                      (1d0/36d0)*a(k+1,l+1)*q0(xk,yk)
                      end do
                   end do
                elseif (example .eq. 1) then
                   write(6,*) 'Discontinuous solution; '
                   stop
                elseif (example .eq. 2) then
                  xi = xlower + (i-1)*dx
                  yj = ylower + (j-1)*dy
                  do k = 0,2
                     do l = 0,2
                        xk = modulo(xi + k*dx/2 - ubar*t,1.d0)
                        yk = modulo(yj + l*dy/2 - vbar*t, 1.d0)
                        soln(i,j,1) = soln(i,j,1) +
     &                      (1d0/36d0)*a(k+1,l+1)*q0(xk,yk)
                      end do
                   end do
                endif
             endif
             error(i,j,1) = q(i,j,1) - soln(i,j,1)
         enddo
      enddo

      end


module parameters_mod

  use real_type_mod
  use variables_mod

  implicit none

!!$  Parameters to be set (later)

  real(kind=wp) :: &
       xmin = 0.0_wp, xmax = 1.0_wp, &
       courant = 0.2_wp, &
       t_end = 0.4_wp, &
       out_every_dt = -1.0_wp, &
       fft_out_every_dt = -1.0_wp

  real(kind=wp), dimension(2) :: &
       initial_n = 1.0_wp, &
       initial_v = 0.0_wp, &
       initial_ptbn_n = 0.0_wp, &
       initial_ptbn_v = 0.0_wp, &
       initial_period_n = 1.0_wp, &
       initial_period_v = 1.0_wp, &
       initial_phase_n = 0.0_wp, &
       initial_phase_v = 0.0_wp

  real(kind=wp), dimension(2) :: &
       eos_m = 1.0, &
       eos_kappa = 0.12, &
       eos_gamma = 1.5, &
       eos_gamma_delta = 1.0, &
       eos_sigma = 1.1_wp
  real(kind=wp) :: &
       eos_kappa_delta = 0.0, &
       eos_kappa_np = 0.0, &
       eos_kappa_ns = 1.0_wp, &
       eos_m_ns = 1.0_wp, &
       eos_alpha = 1.0_wp, &
       eos_beta = 1.33333333333333333333333333_wp, &
       eos_tau = 0.1_wp
  real(kind=wp) :: &
       eos_lambda_0 = 1.0, &
       eos_lambda_1 = 0.1

  real(kind=wp) :: &
       eps_dissipation = 0.0

  integer :: &
       np = 100, &
       gz = 3, &
       rk_order = 3, &
       differencing_order = 4, &
       dissipation_order = 0, &
       out_every_n = 1, &
       fft_out_every_n = 1

  character(len=200) :: &
       out_dir_base = 'results', &
       perturbation_type = 'trig', &
       master_function_type = 'multi_polytrope'

  logical :: &
       out_dir_date = .true., &
       do_fft = .false., &
       vtk_output = .false., &
       vtk_output_binary = .false.

!!$  Derived parameters

  real(kind=wp) :: dx, dt, I2DX, I12DX, I16DX, I64DX, fft_out_dt
  integer :: out_every, fft_out_every, fft_out_total, master_function_i

contains

  subroutine set_parameters(parameter_file)

    character(len=200), intent(in) :: parameter_file

    namelist /parameters/ &
         xmin, xmax, &
         courant, &
         t_end, &
         initial_n, initial_v, &
         initial_ptbn_n, initial_ptbn_v, &
         initial_period_n, initial_period_v, &
         initial_phase_n, initial_phase_v, &
         eos_m, eos_kappa, eos_gamma, eos_gamma_delta, &
         eos_kappa_delta, eos_kappa_np, &
         eos_alpha, eos_tau, eos_sigma, eos_beta, eos_kappa_ns, eos_m_ns, &
         out_every_dt, out_every_n, &
         fft_out_every_dt, fft_out_every_n, &
         np, gz, &
         rk_order, differencing_order, dissipation_order, &
         eps_dissipation, &
         out_dir_base, out_dir_date, &
         perturbation_type, &
         master_function_type, &
         do_fft, &
         vtk_output, vtk_output_binary

    open(3, file=trim(parameter_file), STATUS='old')
    read(3, nml=parameters)

    dx = (xmax - xmin) / dble(np)
    dt = courant * dx
    I2DX  = 1.0_wp / ( 2.0_wp * dx)
    I12DX = 1.0_wp / (12.0_wp * dx)
    I16DX = 1.0_wp / (16.0_wp * dx)
    I64DX = 1.0_wp / (64.0_wp * dx)

    if ( (differencing_order > 2 * gz    ).or.&
         (dissipation_order  > 2 * gz - 1) ) then
      write(*,*) 'Number of ghostzones (gz) too small'
      write(*,'(a10,i2)') 'Number is ', gz
      write(*,'(a29,i2,a24,i2)') 'To match differencing order (', &
           differencing_order, &
           ') gz should be at least ', differencing_order / 2
      write(*,'(a28,i2,a24,i2)') 'To match dissipation order (', &
           dissipation_order, &
           ') gz should be at least ', (dissipation_order + 1) / 2
      stop
    end if

    if (out_every_dt > 0) then
      out_every = floor(out_every_dt / dt)
    else if (out_every_n > 0) then
      out_every = out_every_n
    else
      out_every = 0
    end if
    if (fft_out_every_dt > 0) then
      fft_out_every = floor(fft_out_every_dt / dt)
    else if (fft_out_every_n > 0) then
      fft_out_every = fft_out_every_n
    else
      fft_out_every = 0
    end if
    fft_out_total = ceiling(t_end / dt) / fft_out_every + 1
    fft_out_dt = dble(fft_out_every) * dt
    write(*, *) 'Output every ', out_every, ' steps.'
    write(*, *) 'FFT Output every ', fft_out_every, ' steps.'

    select case (master_function_type)

    case ('multi_polytrope') !!$ Prix, Comer et al

      master_function_i = M_FN_MULTI_POLY
      write(*,*) 'Case now absorbed in ''generic_paper''.'
      stop

    case ('cosmological_poly') !!$ Comer, Peter and Andersson

      master_function_i = M_FN_COSMOLOGICAL_POLY
      write(*,*) 'Case now absorbed in ''generic_paper''.'
      stop

    case ('generic_paper') !!$ Hawke, Comer and Andersson eq (20)
!!$      Note that the parameters listed in the paper include
!!$      kappa_{12} which here is eos_kappa_np

      master_function_i = M_FN_GENERIC_PAPER

    case default

      write(*,*) 'Value of master_function_type parameter not recognized: ', &
           master_function_type
      stop

    end select

  end subroutine set_parameters

end module parameters_mod


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine zhpsi
  use global_variables
  implicit none
! finite difference
  real(dp),parameter :: cN0=-205d0/72d0,cN1=8d0/5d0
  real(dp),parameter :: cN2=-1d0/5d0,cN3=8d0/315d0
  real(dp),parameter :: cN4=-1d0/560d0
  integer :: ix,iy
  real(dp) :: c0,c1,c2,c3,c4
  real(dp) :: c0e,c1e,c2e,c3e,c4e,c0n,c1n,c2n,c3n,c4n
! nine-points formula
  c0e=-0.5d0*cN0/(dx**2)/mu_e
  c1e=-0.5d0*cN1/(dx**2)/mu_e
  c2e=-0.5d0*cN2/(dx**2)/mu_e
  c3e=-0.5d0*cN3/(dx**2)/mu_e
  c4e=-0.5d0*cN4/(dx**2)/mu_e

  c0n=-0.5d0*cN0/(dr**2)/mu_n
  c1n=-0.5d0*cN1/(dr**2)/mu_n
  c2n=-0.5d0*cN2/(dr**2)/mu_n
  c3n=-0.5d0*cN3/(dr**2)/mu_n
  c4n=-0.5d0*cN4/(dr**2)/mu_n

  ztwfn_e_b(:)=0d0
  ztwfn_n_b(:)=0d0
!  tmp_wfn_b(0:Nx,0:NR) = tmp_wfn(0:Nx,0:NR)
  ztwfn_e_b(0:Nx)= ztwfn_e(0:Nx)
  ztwfn_n_b(0:NR)= ztwfn_n(0:NR)
  ztwfn_n_b(-1)= ztwfn_n(1)
  ztwfn_n_b(-2)= ztwfn_n(2)
  ztwfn_n_b(-3)= ztwfn_n(3)
  ztwfn_n_b(-4)= ztwfn_n(4)

  do iy=0,NR
     zhwfn_n(iy) = c0n*ztwfn_n_b(iy) &
      + c1n*( ztwfn_n_b(iy+1) + ztwfn_n_b(iy-1) ) &
      + c2n*( ztwfn_n_b(iy+2) + ztwfn_n_b(iy-2) ) &
      + c3n*( ztwfn_n_b(iy+3) + ztwfn_n_b(iy-3) ) &
      + c4n*( ztwfn_n_b(iy+4) + ztwfn_n_b(iy-4) )
  end do

  do ix=0,Nx
     zhwfn_e(ix) = c0e*ztwfn_e_b(ix) &
      + c1e*( ztwfn_e_b(ix+1) + ztwfn_e_b(ix-1) ) &
      + c2e*( ztwfn_e_b(ix+2) + ztwfn_e_b(ix-2) ) &
      + c3e*( ztwfn_e_b(ix+3) + ztwfn_e_b(ix-3) ) &
      + c4e*( ztwfn_e_b(ix+4) + ztwfn_e_b(ix-4) )

  end do

  zhwfn_n = zhwfn_n + v_n*ztwfn_n
  zhwfn_e = zhwfn_e + v_e*ztwfn_e

  return
end subroutine zhpsi


program main

use test, only: test_value
use io, only: stdout

use eq

implicit none

double precision :: str1, dip1, rak1, str2, dip2, rak2
double precision :: mrr, mpp, mtt, mrp, mrt, mtp
double precision :: pnt(12)
double precision :: slip_vec(3), slip_vec2(3)
double precision :: fth, fss, fno
double precision :: dcp
double precision :: mom, mag
double precision :: wid, len

! mij2dcp
! Moment tensor to double couple percentage
mrr = 4.173d+17
mtt = 7.304d+17
mpp = -1.1477d+18
mrt = -3.5502d+18
mrp = -3.843d+18
mtp = 1.1714d+18
call mij2dcp(mrr,mtt,mpp,mrt,mrp,mtp,dcp)
call test_value(dcp,0.58784927087317074d0,'mij2dcp: dcp')

! mij2mag
call mij2mag(mrr,mtt,mpp,mrt,mrp,mtp,mag,'dc')
call test_value(mag,6.4182434199195217d0,'mij2mag: mag (dc)')
call mij2mag(mrr,mtt,mpp,mrt,mrp,mtp,mag,'nondc')
call test_value(mag,6.4238638576982652d0,'mij2mag: mag (non-dc)')

! mij2mom
! Moment tensor to scalar moment
mrr = 4.173d+17
mtt = 7.304d+17
mpp = -1.1477d+18
mrt = -3.5502d+18
mrp = -3.843d+18
mtp = 1.1714d+18
call mij2mom(mrr,mtt,mpp,mrt,mrp,mtp,mom,'dc')
call test_value(mom,5.3501397941634130d+018,'mij2mom: mom (dc)')
call mij2mom(mrr,mtt,mpp,mrt,mrp,mtp,mom,'nondc')
call test_value(mom,5.4550129578214554d+018,'mij2mom: mom (non-dc)')

! mij2pnt
! Moment tensor to P, N, and T axes
mrr =  1.923d21
mtt = -9.270d20
mpp = -9.970d20
mrt =  3.811d21
mrp = -3.115d21
mtp =  1.033d21
call mij2pnt(mrr,mtt,mpp,mrt,mrp,mtp,pnt)
call test_value(abs(pnt(1)),  0.55173391074654210d0,  'mij2pnt: P axis e-component')
call test_value(abs(pnt(2)),  0.61662524753526782d0,  'mij2pnt: P axis n-component')
call test_value(abs(pnt(3)),  0.56157189729757373d0,  'mij2pnt: P axis z-component')
call test_value(abs(pnt(4)),  0.76332257667899917d0,  'mij2pnt: N axis e-component')
call test_value(abs(pnt(5)),  0.64464366270352003d0,  'mij2pnt: N axis n-component')
call test_value(abs(pnt(6)),  4.2109287198004358d-2,  'mij2pnt: N axis z-component')
call test_value(abs(pnt(7)),  0.33604811510326971d0,  'mij2pnt: T axis e-component')
call test_value(abs(pnt(8)),  0.45189362934020239d0,  'mij2pnt: T axis n-component')
call test_value(abs(pnt(9)),  0.82635574185533400d0,  'mij2pnt: T axis z-component')
call test_value(pnt(10),-5.3220383822829574d+021,'mij2pnt: P magnitude')
call test_value(pnt(11), 4.7233928809523143d+019,'mij2pnt: N magnitude')
call test_value(pnt(12), 5.2738044534734329d+021,'mij2pnt: T magnitude')

! mij2sdr
! Moment tensor to best-fitting double couple strike, dip, and rake
mrr =  1.3892d18
mtt = -8.1410d17
mpp = -5.7510d17
mrt =  5.3130d17
mrp = -7.6200d16
mtp = -8.2620d17
call mij2sdr(mrr,mtt,mpp,mrt,mrp,mtp,str1,dip1,rak1,str2,dip2,rak2)
if (str1.gt.200.0d0) then
    call test_value(str1,213.51387373513245d0,'mij2sdr: str1')
    call test_value(dip1,40.404418834012674d0,'mij2sdr: dip1')
    call test_value(rak1,65.379290596519624d0,'mij2sdr: rak1')
    call test_value(str2,64.553919649886069d0,'mij2sdr: str2')
    call test_value(dip2,53.896206591202564d0,'mij2sdr: dip2')
    call test_value(rak2,109.52541253455682d0,'mij2sdr: rak2')
else
    call test_value(str2,213.51387373513245d0,'mij2sdr: str2')
    call test_value(dip2,40.404418834012674d0,'mij2sdr: dip2')
    call test_value(rak2,65.379290596519624d0,'mij2sdr: rak2')
    call test_value(str1,64.553919649886069d0,'mij2sdr: str1')
    call test_value(dip1,53.896206591202564d0,'mij2sdr: dip1')
    call test_value(rak1,109.52541253455682d0,'mij2sdr: rak1')
endif

! mij2sv
! Moment tensor to slip vectors of best-fitting double couple source
mrr =  1.3892d18
mtt = -8.1410d17
mpp = -5.7510d17
mrt =  5.3130d17
mrp = -7.6200d16
mtp = -8.2620d17
call mij2sv(mrr,mtt,mpp,mrt,mrp,mtp,slip_vec,slip_vec2)
if (slip_vec(1).gt.0.0d0) then
    call test_value(slip_vec(1), 0.34714538840760611d0,'mij2sv: slip_vec_1(1)')
    call test_value(slip_vec(2),-0.72957158138707823d0,'mij2sv: slip_vec_1(2)')
    call test_value(slip_vec(3), 0.58924985103068972d0,'mij2sv: slip_vec_1(3)')
    call test_value(slip_vec2(1),-0.54042032771493020d0,'mij2sv: slip_vec_2(1)')
    call test_value(slip_vec2(2), 0.35788462890633410d0,'mij2sv: slip_vec_2(2)')
    call test_value(slip_vec2(3), 0.76148832018952395d0,'mij2sv: slip_vec_2(3)')
else
    call test_value(slip_vec2(1), 0.34714538840760611d0,'mij2sv: slip_vec_2(1)')
    call test_value(slip_vec2(2),-0.72957158138707823d0,'mij2sv: slip_vec_2(2)')
    call test_value(slip_vec2(3), 0.58924985103068972d0,'mij2sv: slip_vec_2(3)')
    call test_value(slip_vec(1),-0.54042032771493020d0,'mij2sv: slip_vec_1(1)')
    call test_value(slip_vec(2), 0.35788462890633410d0,'mij2sv: slip_vec_1(2)')
    call test_value(slip_vec(3), 0.76148832018952395d0,'mij2sv: slip_vec_1(3)')
endif

! mij2ter
! Moment tensor to fraction thrust, strike-slip, and normal
mrr =  1.4336e+18
mtt = -1.3870e+17
mpp = -1.2949e+18
mrt =  4.7140e+17
mrp = -1.8573e+18
mtp =  1.5080e+17
call mij2ter(mrr,mtt,mpp,mrt,mrp,mtp,fth,fss,fno)
call test_value(fth,0.78904402299330922d0,'mij2ter: fth')
call test_value(fss,2.4806651462488932d-003,'mij2ter: fss')
call test_value(fno,0.20847531186044141d0,'mij2ter: fno')

! pnt2dcp
! P, N, and T axes to double couple percentage
! mrr = 4.173d+17
! mtt = 7.304d+17
! mpp = -1.1477d+18
! mrt = -3.5502d+18
! mrp = -3.843d+18
! mtp = 1.1714d+18
! call mij2pnt(mrr,mtt,mpp,mrt,mrp,mtp,pnt)
pnt(1) = -0.64401587537772065
pnt(2) =  0.31483723501120958
pnt(3) = -0.69722382899034951
pnt(4) =  0.60972258020181702
pnt(5) =  0.76168884485343713
pnt(6) = -0.21924524810785431
pnt(7) =  0.46204104520432626
pnt(8) = -0.56631053237277174
pnt(9) = -0.68250307945837219
pnt(10) = -4.7355476386355784d+018
pnt(11) = -1.2291843110556710d+018
pnt(12) =  5.9647319496912486d+018
call pnt2dcp(pnt,dcp)
call test_value(dcp,0.58784927087317074d0,'pnt2dcp: dcp')

! pnt2mij
! P, N, and T axes to moment tensor
pnt(1) =   0.55173391074654210d0
pnt(2) =   0.61662524753526782d0
pnt(3) =   0.56157189729757373d0
pnt(4) =   0.76332257667899917d0
pnt(5) =  -0.64464366270352003d0
pnt(6) =   -4.2109287198004358d-002
pnt(7) =   0.33604811510326971d0
pnt(8) =   0.45189362934020239d0
pnt(9) =  -0.82635574185533400d0
pnt(10) =   -5.3220383822829574d+021
pnt(11) =    4.7233928809523143d+019
pnt(12) =    5.2738044534734329d+021
call pnt2mij(pnt,mrr,mtt,mpp,mrt,mrp,mtp)
call test_value(mrr, 1.9229999999999987d+021,'pnt2mij: mrr')
call test_value(mtt,-9.2700000000000092d+020,'pnt2mij: mtt')
call test_value(mpp,-9.9700000000000039d+020,'pnt2mij: mpp')
call test_value(mrt, 3.8109999999999997d+021,'pnt2mij: mrt')
call test_value(mrp,-3.1150000000000003d+021,'pnt2mij: mrp')
call test_value(mtp, 1.0330000000000004d+021,'pnt2mij: mtp')

! pnt2mag
call pnt2mag(pnt,mag)
call test_value(mag,8.4154036748523371d0,'pnt2mag: mag')
call pnt2mag_nondc(pnt,mag)
call test_value(mag,8.4154124278966620d0,'pnt2mag_nondc: mag')

! pnt2mom
! P, N, and T axes to scalar moment
pnt(1) = -0.64401587537772065
pnt(2) =  0.31483723501120958
pnt(3) = -0.69722382899034951
pnt(4) =  0.60972258020181702
pnt(5) =  0.76168884485343713
pnt(6) = -0.21924524810785431
pnt(7) =  0.46204104520432626
pnt(8) = -0.56631053237277174
pnt(9) = -0.68250307945837219
pnt(10) = -4.7355476386355784d+018
pnt(11) = -1.2291843110556710d+018
pnt(12) =  5.9647319496912486d+018
call pnt2mom(pnt,mom)
call test_value(mom,5.3501397941634130d+018,'pnt2mom: mom')
call pnt2mom_nondc(pnt,mom)
call test_value(mom,5.4550129578214554d+018,'pnt2mom_nondc: mom')

! pnt2sdr
! P, N, and T axes to best-fitting double couple strike, dip, and rake
pnt(1) =  0.62760373661893987d0
pnt(2) = -0.76894766054189612d0
pnt(3) = -0.12179098952340160d0
pnt(4) =  0.76644370223769165d0
pnt(5) =  0.58278975628002727d0
pnt(6) =  0.27003731459790342d0
pnt(7) = -0.13666602021762725d0
pnt(8) = -0.26282236457769625d0
pnt(9) =  0.95511612047732908d0
pnt(10) = -1.5725830409879032d18
pnt(11) =  2.6280182158839164d16
pnt(12) =  1.5463028588290642d18
call pnt2sdr(pnt,str1,dip1,rak1,str2,dip2,rak2)
call test_value(str1,213.51387373513245d0,'pnt2sdr: str1')
call test_value(dip1,40.404418834012674d0,'pnt2sdr: dip1')
call test_value(rak1,65.379290596519624d0,'pnt2sdr: rak1')
call test_value(str2,64.553919649886069d0,'pnt2sdr: str2')
call test_value(dip2,53.896206591202564d0,'pnt2sdr: dip2')
call test_value(rak2,109.52541253455682d0,'pnt2sdr: rak2')

! pnt2sv
mrr =  1.3892d18
mtt = -8.1410d17
mpp = -5.7510d17
mrt =  5.3130d17
mrp = -7.6200d16
mtp = -8.2620d17
call mij2pnt(mrr,mtt,mpp,mrt,mrp,mtp,pnt)
call pnt2sv(pnt,slip_vec,slip_vec2)
if (slip_vec(1).gt.0.0d0) then
    call test_value(slip_vec(1), 0.34714538840760611d0,'pnt2sv: slip_vec_1(1)')
    call test_value(slip_vec(2),-0.72957158138707823d0,'pnt2sv: slip_vec_1(2)')
    call test_value(slip_vec(3), 0.58924985103068972d0,'pnt2sv: slip_vec_1(3)')
    call test_value(slip_vec2(1),-0.54042032771493020d0,'pnt2sv: slip_vec_2(1)')
    call test_value(slip_vec2(2), 0.35788462890633410d0,'pnt2sv: slip_vec_2(2)')
    call test_value(slip_vec2(3), 0.76148832018952395d0,'pnt2sv: slip_vec_2(3)')
else
    call test_value(slip_vec2(1), 0.34714538840760611d0,'pnt2sv: slip_vec_2(1)')
    call test_value(slip_vec2(2),-0.72957158138707823d0,'pnt2sv: slip_vec_2(2)')
    call test_value(slip_vec2(3), 0.58924985103068972d0,'pnt2sv: slip_vec_2(3)')
    call test_value(slip_vec(1),-0.54042032771493020d0,'pnt2sv: slip_vec_1(1)')
    call test_value(slip_vec(2), 0.35788462890633410d0,'pnt2sv: slip_vec_1(2)')
    call test_value(slip_vec(3), 0.76148832018952395d0,'pnt2sv: slip_vec_1(3)')
endif

! pnt2ter
! P, N, and T axes to fraction thrust, strike-slip, and normal
pnt(1) =  0.62760373661893987d0
pnt(2) = -0.76894766054189612d0
pnt(3) = -0.12179098952340160d0
pnt(4) =  0.76644370223769165d0
pnt(5) =  0.58278975628002727d0
pnt(6) =  0.27003731459790342d0
pnt(7) = -0.13666602021762725d0
pnt(8) = -0.26282236457769625d0
pnt(9) =  0.95511612047732908d0
pnt(10) = -1.5725830409879032d18
pnt(11) =  2.6280182158839164d16
pnt(12) =  1.5463028588290642d18
call pnt2ter(pnt,fth,fss,fno)
call test_value(fth,0.91224680359566357d0,'pnt2ter: fth')
call test_value(fss,7.2920151275247064d-002,'pnt2ter: fss')
call test_value(fno,1.4833045129089315d-002,'pnt2ter: fno')

! sdr2mij
! Strike, dip, and rake to moment tensor in spherical coordinates
str1 = 9.0d0
dip1 = 39.0d0
rak1 = 167.0d0
call sdr2mij(str1,dip1,rak1,mrr,mtt,mpp,mrt,mrp,mtp)
call test_value(mrr, 0.22003533408899165d0,'sdr2mij: mrr')
call test_value(mtt, 0.18410177651383547d0,'sdr2mij: mtt')
call test_value(mpp,-0.40413711060282714d0,'sdr2mij: mpp')
call test_value(mrt, 0.74058859778607167d0,'sdr2mij: mrt')
call test_value(mrp,-0.16465065799140619d0,'sdr2mij: mrp')
call test_value(mtp, 0.54918192012069555d0,'sdr2mij: mtp')

! sdr2pnt
! Strike, dip, and rake to P, N, and T axes
str1 = 214.0d0
dip1 = 40.0d0
rak1 = 65.0d0
call sdr2pnt(str1,dip1,rak1,pnt)
call test_value(abs(pnt(1)), 0.61670145162508538d0,'sdr2pnt: P axis e-component')
call test_value(abs(pnt(2)), 0.77643201628987624d0,'sdr2pnt: P axis n-component')
call test_value(abs(pnt(3)), 0.12974067844569803d0,'sdr2pnt: P axis z-component')
call test_value(abs(pnt(4)), 0.77519713030606596d0,'sdr2pnt: N axis e-component')
call test_value(abs(pnt(5)), 0.57032765296921284d0,'sdr2pnt: N axis n-component')
call test_value(abs(pnt(6)), 0.27165378227418457d0,'sdr2pnt: N axis z-component')
call test_value(abs(pnt(7)), 0.13692599727134791d0,'sdr2pnt: T axis e-component')
call test_value(abs(pnt(8)), 0.26810388348300168d0,'sdr2pnt: T axis n-component')
call test_value(abs(pnt(9)), 0.95360976239370576d0,'sdr2pnt: T axis z-component')
call test_value(pnt(10),-1.0d0,'sdr2pnt: P magnitude')
call test_value(pnt(11), 0.0d0,'sdr2pnt: N magnitude')
call test_value(pnt(12), 1.0d0,'sdr2pnt: T magnitude')

! sdr2sdr
! Strike, dip, and rake to strike, dip, and rake of second nodal plane
str1 = 222.0d0
dip1 = 52.0d0
rak1 = -119.0d0
call sdr2sdr(str1,dip1,rak1,str2,dip2,rak2)
call test_value(str2,83.998199510808121d0,'sdr2sdr: normal str')
call test_value(dip2,46.432414978165248d0,'sdr2sdr: normal dip')
call test_value(rak2,-58.179239464578913d0,'sdr2sdr: normal rak')
str1 = 109.0d0
dip1 = 82.0d0
rak1 = 52.0d0
call sdr2sdr(str1,dip1,rak1,str2,dip2,rak2)
call test_value(str2,8.8996492587401121d0,'sdr2sdr: oblique str')
call test_value(dip2,38.708111069705964d0,'sdr2sdr: oblique dip')
call test_value(rak2,167.14107738093375d0,'sdr2sdr: oblique rak')

! sdr2sv
! Strike, dip, and rake to slip vector
str1 = 292.0d0
dip1 = 43.0d0
rak1 = 124.0d0
call sdr2sv(str1,dip1,rak1,slip_vec)
call test_value(slip_vec(1), 0.29134327529638415d0,'sdr2sv: slip vector e-component')
call test_value(slip_vec(2),-0.77164718283107014d0,'sdr2sv: slip vector e-component')
call test_value(slip_vec(3), 0.56540226491273315d0,'sdr2sv: slip vector e-component')

! sdr2ter
! Strike, dip, and rake to fraction thrust, strike-slip, and normal
str1 = 357.0d0
dip1 = 18.0d0
rak1 = 99.0d0
call sdr2ter(str1,dip1,rak1,fth,fss,fno)
call test_value(fth,0.78910589852855950d0,'sdr2ter: fth')
call test_value(fss,2.3368434059280944d-3,'sdr2ter: fss')
call test_value(fno,0.20855725806551242d0,'sdr2ter: fno')

! mom2mag
mag = 7.0d0
call mag2mom(mag,mom)
call test_value(mom,3.9902490236214116d+019,'mag2mom')

! mag2mom
call mom2mag(mom,mag)
call test_value(mag,7.0d0,'mom2mag')

! empirical
mag = 7.1d0
! Wells and Coppersmith (1994)
call empirical(mag,wid,len,'WC','ss')
call test_value(wid,14.354894333536560d0,'empirical: WC-ss wid')
call test_value(len,67.920363261718506d0,'empirical: WC-ss len')
call empirical(mag,wid,len,'WC','th')
call test_value(wid,19.998618696327419d0,'empirical: WC-th wid')
call test_value(len,49.888448746001167d0,'empirical: WC-th len')
call empirical(mag,wid,len,'WC','no')
call test_value(wid,22.130947096056374d0,'empirical: WC-no wid')
call test_value(len,46.773514128719810d0,'empirical: WC-no len')
call empirical(mag,wid,len,'WC','ot')
call test_value(wid,18.281002161427416d0,'empirical: WC-ot wid')
call test_value(len,56.104797603246951d0,'empirical: WC-ot len')
call empirical(mag,wid,len,'WC:print','')
! Mai and Beroza (2000)
call empirical(mag,wid,len,'MB','ss')
call test_value(wid,15.054627009958807d0,'empirical: MB-ss wid')
call test_value(len,38.940363387971708d0,'empirical: MB-ss len')
call empirical(mag,wid,len,'MB','th')
call test_value(wid,25.284245587128211d0,'empirical: MB-th wid')
call test_value(len,32.389183499687725d0,'empirical: MB-th len')
call empirical(mag,wid,len,'MB','no')
call test_value(wid,25.284245587128211d0,'empirical: MB-no wid')
call test_value(len,32.389183499687725d0,'empirical: MB-no len')
call empirical(mag,wid,len,'MB','ot')
call test_value(wid,18.634596787704442d0,'empirical: MB-ot wid')
call test_value(len,37.401584391018623d0,'empirical: MB-ot len')
call empirical(mag,wid,len,'MB:print','')
! Blaser et al. (2010)
call empirical(mag,wid,len,'B','ss')
call test_value(wid,16.710906143107071d0,'empirical: B-ss wid')
call test_value(len,71.449632607551280d0,'empirical: B-ss len')
call empirical(mag,wid,len,'B','th')
call test_value(wid,25.468302525850405d0,'empirical: B-th wid')
call test_value(len,47.533522594280484d0,'empirical: B-th len')
call empirical(mag,wid,len,'B','no')
call test_value(wid,22.698648518838201d0,'empirical: B-no wid')
call test_value(len,60.534087475391331d0,'empirical: B-no len')
call empirical(mag,wid,len,'B','ot')
call test_value(wid,22.438819237827637d0,'empirical: B-ot wid')
call test_value(len,54.575786109127051d0,'empirical: B-ot len')
call empirical(mag,wid,len,'B:print','')
! Yen and Ma (2011)
call empirical(mag,wid,len,'YM','ss')
call test_value(wid,42.210451736368604d0,'empirical: YM-ss wid')
call test_value(len,58.277377479636769d0,'empirical: YM-ss len')
call empirical(mag,wid,len,'YM','th')
call test_value(wid,35.307746515410926d0,'empirical: YM-th wid')
call test_value(len,43.193659462830965d0,'empirical: YM-th len')
call empirical(mag,wid,len,'YM','no')
call test_value(wid,35.307746515410926d0,'empirical: YM-no wid')
call test_value(len,43.193659462830965d0,'empirical: YM-no len')
call empirical(mag,wid,len,'YM','ot')
call test_value(wid,39.847400971777475d0,'empirical: YM-ot wid')
call test_value(len,66.522720234738060d0,'empirical: YM-ot len')
call empirical(mag,wid,len,'YM:print','')
! Allen and Hayes (2017)
call empirical(mag,wid,len,'AH','ss')
call test_value(wid,12.445146117713850d0,'empirical: AH-ss wid')
call test_value(len,46.025657358135582d0,'empirical: AH-ss len')
call empirical(mag,wid,len,'AH','th')
call test_value(wid,31.477483141013156d0,'empirical: AH-th wid')
call test_value(len,37.411058827205331d0,'empirical: AH-th len')
call empirical(mag,wid,len,'AH','no')
call test_value(wid,20.183663636815606d0,'empirical: AH-no wid')
call test_value(len,40.086671762730262d0,'empirical: AH-no len')
call empirical(mag,wid,len,'AH','ot')
call test_value(wid,29.853826189179586d0,'empirical: AH-ot wid')
call test_value(len,27.733201046518410d0,'empirical: AH-ot len')
call empirical(mag,wid,len,'AH:print','')

write(stdout,*) 'eq_module unit test passed'
end


c  de-redshift a spectrum by z, in log space.  this means
c  shifting wl scale by -log(1+z).

c do the shift into a new array with possibly different wl zeropoint
c but same dw/dpix
      subroutine deshiftz2(spec,nsp,w0,dwlog,z,specout,nspout,w0out)
c      subroutine deshiftz2(spec,nsp,dwlog,z)

      real spec(nsp)
      real specout(nspout)

      include 'pcredshift.h'

      dzlog = log10(1.+z)
c this is the shift due to deredshifting. positive moves high index to low
      dindx = dzlog / dwlog
c this is the shift due to zeropoint.  if w0out<w0, index for a given
c wl increases, so dindx2 is negative
      dindx2 = (w0out-w0) / dwlog
c total shift
      dindx = dindx + dindx2
      ishift = int(dindx)
      fshift = dindx - ishift

c now ishift and fshift are the positive integer and fractional
c shifts (if z is positive).  we want to shift to lower w
c  i indexes the new array
c  j1 indexes the old array
c      do i=1,nsp
      do i=1,nspout
         j1 = i + ishift
         if (j1 .ge. 1 .and. j1+1 .le. nsp) then
            if (spec(j1) .gt. bad .and. spec(j1+1) .gt. bad) then
               specout(i) = (1.-fshift)*spec(j1) + fshift*spec(j1+1)
            else if (spec(j1) .gt. bad) then
               specout(i) = spec(j1)
            else if (spec(j1+1) .gt. bad) then
               specout(i) = spec(j1+1)
            else
               specout(i) = badset
            end if
         else
            specout(i) = badset
         end if
      end do
c to deshift in place
c      do i=1,nsp
c         spec(i) = specout(i)
c      end do

      return
      end


Program Ejemplo17

IMPLICIT NONE
!
!	Uso de vectores y matrices
!
! OBSERVE los Warnings!!
!

Integer :: Vector(10), ii, jj, kk

Integer :: Vect(2:8)

Real, dimension(2, 3)  :: Matriz = reshape([0.0,0.0,0.0,0.0,0.0,0.0], (/2, 3/))
Real :: Mati(3,3) = 1.0
Real :: Mat1(3,3), Mat2(3,3) = 3.0
Real :: MatMat(1:4, 3:5)

!Metodo para crear y alojar formas diferidas de arreglos
INTEGER,ALLOCATABLE :: Matu(:,:)
REAL, ALLOCATABLE ::  Vvector(:)

Integer :: AllocateStatus, DeAllocateStatus

Vect = 1
Mat1 = 2.0
Mat2 = 3.0

Do ii = 1, 3
Do jj = 1, 3
 Mat1(ii, jj) = -1
 Mat2(ii, jj) = jj
End Do
End Do

Print*, 'Matriz * Mati'
Print*, Mat1*Mat2

Print*, 'Ingrese las dimensiones de la matriz y del vector : (ejemplos 2 4 6) '
Read*, 	ii, jj, kk

Allocate(Matu(ii, jj), STAT = AllocateStatus)
If ( AllocateStatus /= 0)  STOP '++++ No hay suficiente memoria+++'

Allocate(Vvector(kk), STAT = AllocateStatus)
If ( AllocateStatus /= 0)  STOP '++++ No hay suficiente memoria+++'

Matu = 3
Vvector = 8

Print *, Matu
Print *, '******************************'
Print *, Vvector
Print*, '******************************'

!Un Arreglo puede ser liberado de la memoria, usando el comando DEALLOCATE

   DeAllocate (Matu, STAT = DeAllocateStatus)
   Print*, 'DeAllocateStatus ', DeAllocateStatus

! Y lo podemos alojar de nuevo con ALLOCATE

Allocate(Matu(3,3))
Matu = 9
Print*, Matu

! Stop

Print*, 'Imprimo Vect :', Vect
Print*, '**********************'
Print*,'Mati...:', Mati

Do ii = 2, 8

	Vect(ii) = ii

End Do

	Print *, 'Vect(',ii,')',Vect(ii)

	Vect(0) = 0
	Vect(9) = 9

	Print *, 'Vect(0)',Vect(0)
	Print *, 'Vect(1)',Vect(1)
	Print *, 'Vect(9)',Vect(9)

Do ii = 0, 11

	Vector(ii) = ii + 2

End Do

Do ii = 0, 11
	Print *, ii, Vector(ii)
End Do

Do ii = 1, 2

  Do jj = 1, 3

	Matriz(ii, jj) = ii + jj

  End Do

End Do

Do ii = 1, 2

 Do jj = 1, 3

	Print *, ii, jj, Matriz(ii, jj)

  End Do

End Do

Do ii = 1, 3

 Do jj = 1, 3

	Print *, ii, jj, Mati(ii, jj)

  End Do

End Do

Do ii = 1, 4

  Do jj = 3, 5

	MatMat(ii, jj) = ii + jj

  End Do

End Do

Do ii = 1, 4

  Do jj = 3, 5

	Print *, 'MatMat', ii, jj, MatMat(ii, jj)

  End Do

End Do

End Program Ejemplo17


      SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INCX, INCY, N
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      COMPLEX*16         AP( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  ZSPMV  performs the matrix-vector operation
*
*     y := alpha*A*x + beta*y,
*
*  where alpha and beta are scalars, x and y are n element vectors and
*  A is an n by n symmetric matrix, supplied in packed form.
*
*  Arguments
*  ==========
*
*  UPLO   - CHARACTER*1
*           On entry, UPLO specifies whether the upper or lower
*           triangular part of the matrix A is supplied in the packed
*           array AP as follows:
*
*              UPLO = 'U' or 'u'   The upper triangular part of A is
*                                  supplied in AP.
*
*              UPLO = 'L' or 'l'   The lower triangular part of A is
*                                  supplied in AP.
*
*           Unchanged on exit.
*
*  N      - INTEGER
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - COMPLEX*16
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  AP     - COMPLEX*16 array, dimension at least
*           ( ( N*( N + 1 ) )/2 ).
*           Before entry, with UPLO = 'U' or 'u', the array AP must
*           contain the upper triangular part of the symmetric matrix
*           packed sequentially, column by column, so that AP( 1 )
*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*           and a( 2, 2 ) respectively, and so on.
*           Before entry, with UPLO = 'L' or 'l', the array AP must
*           contain the lower triangular part of the symmetric matrix
*           packed sequentially, column by column, so that AP( 1 )
*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*           and a( 3, 1 ) respectively, and so on.
*           Unchanged on exit.
*
*  X      - COMPLEX*16 array, dimension at least
*           ( 1 + ( N - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the N-
*           element vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  BETA   - COMPLEX*16
*           On entry, BETA specifies the scalar beta. When BETA is
*           supplied as zero then Y need not be set on input.
*           Unchanged on exit.
*
*  Y      - COMPLEX*16 array, dimension at least
*           ( 1 + ( N - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y. On exit, Y is overwritten by the updated
*           vector y.
*
*  INCY   - INTEGER
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
* =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
      COMPLEX*16         TEMP1, TEMP2
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = 1
      ELSE IF( N.LT.0 ) THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 ) THEN
         INFO = 6
      ELSE IF( INCY.EQ.0 ) THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZSPMV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     Set up the start points in  X  and  Y.
*
      IF( INCX.GT.0 ) THEN
         KX = 1
      ELSE
         KX = 1 - ( N-1 )*INCX
      END IF
      IF( INCY.GT.0 ) THEN
         KY = 1
      ELSE
         KY = 1 - ( N-1 )*INCY
      END IF
*
*     Start the operations. In this version the elements of the array AP
*     are accessed sequentially with one pass through AP.
*
*     First form  y := beta*y.
*
      IF( BETA.NE.ONE ) THEN
         IF( INCY.EQ.1 ) THEN
            IF( BETA.EQ.ZERO ) THEN
               DO 10 I = 1, N
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20 I = 1, N
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO ) THEN
               DO 30 I = 1, N
                  Y( IY ) = ZERO
                  IY = IY + INCY
   30          CONTINUE
            ELSE
               DO 40 I = 1, N
                  Y( IY ) = BETA*Y( IY )
                  IY = IY + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      KK = 1
      IF( LSAME( UPLO, 'U' ) ) THEN
*
*        Form  y  when AP contains the upper triangle.
*
         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
            DO 60 J = 1, N
               TEMP1 = ALPHA*X( J )
               TEMP2 = ZERO
               K = KK
               DO 50 I = 1, J - 1
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2 = TEMP2 + AP( K )*X( I )
                  K = K + 1
   50          CONTINUE
               Y( J ) = Y( J ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
               KK = KK + J
   60       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 80 J = 1, N
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ZERO
               IX = KX
               IY = KY
               DO 70 K = KK, KK + J - 2
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2 = TEMP2 + AP( K )*X( IX )
                  IX = IX + INCX
                  IY = IY + INCY
   70          CONTINUE
               Y( JY ) = Y( JY ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + J
   80       CONTINUE
         END IF
      ELSE
*
*        Form  y  when AP contains the lower triangle.
*
         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
            DO 100 J = 1, N
               TEMP1 = ALPHA*X( J )
               TEMP2 = ZERO
               Y( J ) = Y( J ) + TEMP1*AP( KK )
               K = KK + 1
               DO 90 I = J + 1, N
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2 = TEMP2 + AP( K )*X( I )
                  K = K + 1
   90          CONTINUE
               Y( J ) = Y( J ) + ALPHA*TEMP2
               KK = KK + ( N-J+1 )
  100       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 120 J = 1, N
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ZERO
               Y( JY ) = Y( JY ) + TEMP1*AP( KK )
               IX = JX
               IY = JY
               DO 110 K = KK + 1, KK + N - J
                  IX = IX + INCX
                  IY = IY + INCY
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2 = TEMP2 + AP( K )*X( IX )
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP2
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + ( N-J+1 )
  120       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of ZSPMV
*
      END