PROGRAM HeatRater
!   ******************************************************************
!     Adapted and updated to f90 by Rohit Goswami
!        and Shaivya Anand
!       from Kayode's Fortran programs for chemical
!       process design analysis and simulation
!       (c) 2018 Rohit Goswami [HaoZeke] <haozeke@yandex.com>
!       License: MIT
!   THIS PROGRAM RATES A SHELL AND TUBE HEAT EXCHANGER WITH
!   EITHER A SINGLE SHELL PASS AND ANY MULTIPLE OF TWO TUBE
!   PASSES PR TWO OR MORE SHELL PASSES.
!   THE PROGRAM ASSUMES THAT THERE IS NO CHANGE OF PHASE.
!
!   THE PROGRAM USES DEVELOPED CORRELATIONS FOR FRICTION FACTORS
!   IN BOTH THE SHELL AND TUBE SIDES. HEDRICK'S CORRELATION
!   (Chem. Eng. June, 1990) FOR ESTIMATING THE HEAT TRANSFER
!   COEFFICIENT FOR TUBES IN THE TRANSITION REGION IS EMPLOYED
!   IN THE PROGRAM
!   ******************************************************************
!
!   NOMENCLATURE:               TUBE SIDE
!
!   1.    FLUID TYPE                                =     FTS
!   2.    NUMBER OF TUBES                           =     NT
!   3.    TUBE INSIDE DIA., inch                    =     TID
!   4.    TUBE OUTSIDE DIA., inch                   =     TOD
!   5.    TUBE PITCH, inch                          =     TP
!   6.    PITCH TYPE (TRIANGLE/SQUARE)              =     T/S
!   7.    TUBE LENGTH, ft.                          =     TL
!   8.    NUMBER OF PASSES                          =     TNP
!   9.    FOULING FACTOR                            =     TFF
!   10.   INLET TEMPERATURE, oF                     =     TT1
!   11.   OUTLET TEMPERATURE, oF                    =     TT2
!   12.   SPECIFIC HEAT CAPACITY (Btu/lboF)         =     TSHC
!   13.   VISCOSITY, cP                             =     TVIS
!   14.   DENSITY, lb/ft^3                          =     TDEN
!   15.   FLUID THERMAL CONDUCTIVITY (Btu/ft.h.oF)  =     TFK
!   16.   MASS FLOWRATE, lb/hr                      =     TW
!
!   NOMENCLATURE:             SHELL SIDE
!
!   1.    FLUID TYPE                                =     FSS
!   2.    NUMBER OF SHELL PASSES                    =     NS
!   3.    SHELL INSIDE DIA., inch                   =     SID
!   4.    NUMBER OF BAFFLES                         =     NB
!   5.    BAFFLE SPACING, inch                      =     BSP
!   6.    FOULING FACTOR                            =     SFF
!   7.    INLET TEMPERATURE, oF                     =     TS1
!   8.    OUTLET TEMPERATURE, oF                    =     TS2
!   9.    SPECIFIC HEAT CAPACITY (Btu/lboF)         =     SSHC
!   10.   VISCOSITY, cP                             =     SVIS
!   11.   DENSITY, lb/ft^3                          =     SDEN
!   12.   FLUID THERMAL CONDUCTIVITY (Btu/ft.h.oF)  =     SFK
!   13.   MASS FLOWRATE, lb/hr                      =     SW
!   ******************************************************************

PARAMETER (PI = 3.1415927, G=32.174)

CHARACTER*30 FTS, FSS
CHARACTER TYPE
!
COMMON/TUBE1/ FTS, TYPE
COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
COMMON/TUBE4/ TFK, TW
COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
COMMON/TUBE6/ TDELP, TRDELP, TOTDP
COMMON/SHELL1/ FSS
COMMON/SHELL2/ NS, SID, NB, BSP, SFF
COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
COMMON/SHELL4/ SFK, SW
COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
COMMON/SHELL6/ SDELP

COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

REAL NT, NS, NB, LMTD

OPEN (UNIT = 3, FILE = 'DATA82.DAT', STATUS ='OLD', ERR = 18)
OPEN (UNIT = 1, FILE = 'PRN')

!   READ THE TUBE SIDE HEAT EXCHANGER PARAMETERS

!   READ THE FLUID TYPE: FTS

READ (3, 11, ERR = 19) FTS
11 FORMAT (A)

!   READ THE NUMBER OF TUBES: NT
!   READ THE TUBE INSIDE DIAMETER, inch : TID
!   READ THE TUBE OUTSIDE DIAMETER, inch : TOD
!   READ THE TUBE PITCH, inch : TP
!   READ THE TYPE OF PITCH (TRIANGULAR: T) or (SQUARE: S): TYPE

READ (3, *, ERR= 19) NT, TID, TOD, TP
READ (3, 12, ERR= 19) TYPE
12 FORMAT   (A)

!   READ THE TUBE LENGTH, ft. : TL
!   READ THE NUMBER OF PASSES : TNP
!   READ THE TUBE SIDE FOULING FACTOR : TFF
!   READ THE INLET TEMPERATURE, oF : TT1
!   READ THE OUTLET TEMPERATURE, oF : TT2
!   READ THE SPECIFIC HEAT CAPACITY OF FLUID, (Btu/hr.ft.oF) : TSHC
!   READ THE FLUID THERMAL CONDUCTIVITY (Btu/ft.h.oF) : TFK
!   READ THE FLUID VISCOSITY, cP : TVIS
!   READ THE FLUID DENSITY, lb/ft^3 : TDEN
!   READ THE FLUID FLOWRATE, lb/hr.: TW

READ (3, *, ERR=19) TL, TNP, TFF, TT1
READ (3, *, ERR=19) TT2, TSHC, TVIS, TDEN
READ (3, *, ERR=19) TFK, TW

!   READ THE SHELL SIDE HEAT EXCHANGER PARAMETERS

!   READ THE FLUID TYPE: FSS

READ (3, 13, ERR=19) FSS

13 FORMAT   (A)

!   READ THE NUMBER OF SHELL: NS
!   READ THE SHELL SIDE INSIDE DIAMETER, inch: SID
!   READ THE NUMBER OF BAFFLES: NB
!   READ THE BAFFLE SPACING, inch: BSP
!   READ THE SHELL SIDE FOULING FACTOR, SFF
!   READ THE INLET TEMPERATURE, oF: TSI
!   READ THE OULET TEMPERATURE, oF: TS2
!   SHELL SIDE SPECIFIC HEAT CAPACITY, Btu/ib.oF.: SSHC
!   READ THE FLUID VISCOSITY, cP: SVIS
!   READ THE FLUID DENSITY, ib/ft^3.: SDEN
!   READ THE FLUID THERMAL CONDUCTIVITY, Btu/hr.ft.oF.: SFK
!   READ THE FLUID FLOWRATE, ib/hr.: SW.

READ (3, *, ERR=19) NS, SID, NB, BSP
READ (3, *, ERR=19) SFF, TS1, TS2, SSHC
READ (3, *, ERR=19) SVIS, SDEN, SFK, SW

GO TO 15

18 WRITE    (*, 20)
20 FORMAT   (3X, 'ERROR MESSAGE IN THE DATA VALUE')
GO TO 999
19 WRITE    (*, 21)
21 FORMAT   (3X, 'DATA VALUE DOES NOT EXIST')
GO TO 999

!   TUBE SIDE CALCULATION

15 CALL   TUBE

!   SHELL SIDE CALCULATION
CALL SHELL
!   CALCULATE THE HEAT LOAD
Q = TW*TSHC*ABS(TT2-TT1)
!   CALCULATE THE LOG MEAN TEMPERATURE DIFFERENCE (LMTD)

VAL1 = (TS1-TT2)-(TS2-TT1)
VAL2 = ALOG((TS1-TT2)/(TS2-TT1))
LMTD = ABS(VAL1/VAL2)
!   CALCULATE THE APPROACH FACTOR
R = (TS1-TS2)/(TT2-TT1)
P = (TT2-TT1) / (TS1-TT1)

IF (NS .EQ. 1.0 .AND. R .EQ. 1.0) THEN
PX = P/(NS-NS*P+P)
SUM1 = (PX*(R*R+1.0)**0.5)/(1.0-PX)
SUM2 = 2.0/PX-1.0-R+(R*R+1.0)**0.5
SUM3 = 2.0/PX-1.0-R-(R*R+1.0)**0.5
SUM4 = ALOG(SUM2/SUM3)
F = SUM1/SUM4
GO TO 100
ELSEIF (NS .EQ. 1.0 .AND. R .GT. 1.0) THEN
55   SUM5 = ((R*P-1.0)/(P-1.0))**(1.0/NS)
PX = (1.0-SUM5)/(R-SUM5)
SUM6 = (R*R+1.0)**0.5/(R-1.0)
SUM7 = ALOG((1.0-PX)/(1.0-R*PX))
SUM41 = ((2.0/PX)-1.0-R+(R*R+1.0)**0.5)
SUM42 = ((2.0/PX)-1.0-R-(R*R+1.0)**0.5)
!   Broken IF maybe. (dangling)

IF (SUM41 .LT. 0.0 .OR. SUM42 .LT. 0.0) THEN
NS = NS+1.
TNP = TNP+2.
GO TO 55
ELSE
SUM43 = ALOG(SUM41/SUM42)
ENDIF

F = (SUM6*SUM7)/SUM43

IF (F .LT. 0.8) THEN
NS = NS+1.0
TNP = TNP+2.
GO TO 55
ELSE
END IF

GO TO 100

ELSEIF (NS .GE. 2.0 .AND. NT .GE. 4.0) THEN
SUM8 = (R*R+1.0)**0.5/(2.0*(R-1.0))
SUM9 = ALOG((1.0-P)/(1.0-P*R))
SUM10 = 2/P-1.0-R+((2/P)*((1.0-P)*(1-P*R))**0.5)+(R*R+1.)**0.5
SUM11 = 2/P-1.0-R+((2/P)*((1.0-P)*(1.-P*R))**0.5)-(R*R+1.)**0.5

F = (SUM8*SUM9)/ALOG(SUM10/SUM11)
ENDIF

!   CORRECTED MEAN TEPERATURE

100 CMTD=F*LMTD

! CALCULATE THE OVERALL HEAT TRANSFER COEFFICIENT
! Btu/hr.ft^2.oF

U = 1.0/(1./HT+1./HS+TFF+SFF)

!   CALCULATE THE OUTSIDE AREA OF THE HEAT EXCHANGER UNIT ft^2

AREA=(TOD/12.0*TP*NT*NS*TL)

Q1 = AREA*U*CMTD
CALL RESULT

!   FORM FEED THE PRINTING PAPER TO TOP OF THE NEXT PAGE.

WRITE (1, *) CHAR(12)

CLOSE (UNIT=3, STATUS='KEEP')
CLOSE (UNIT=1)
999 STOP
END

!   *THIS PROGRAM CALCULATES TUBE TUBE SIDE HEAT TRANSFER COEFFICIENT,
!   * REYNOLDS NUMBER, PRANDTL NUMBER, FRICTION FACTOR AND PRESSURE DROP

SUBROUTINE TUBE
PARAMETER (PI = 3.1415927, G = 32.174)
CHARACTER*30 FTS, FSS
CHARACTER TYPE

COMMON/TUBE1/ FTS, TYPE
COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
COMMON/TUBE4/ TFK, TW
COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
COMMON/TUBE6/ TDELP, TRDELP, TOTDP
COMMON/SHELL1/ FSS
COMMON/SHELL2/ NS, SID, NB, BSP, SFF
COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
COMMON/SHELL4/ SFK, SW
COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
COMMON/SHELL6/ SDELP

COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

REAL NT, NS, NB, LMTD

!   CALCULTAE THE FLOW AREA: TFA, ft^2

TFA = (PI*TID**2*NT)/(4.0*144.0*TNP)

!   CALCULATE THE MASS VELOCITY, ib/hr.ft^2

GT = TW/TFA

! CALCULATE THE REYNOLDS NUMBER: RET

RET = (GT*TID)/(12.0*2.42*TVIS)

!   CALCULATE THE PRANDTL NUT[BER: PRT

PRT = (TSHC*TVIS*2.42)/TFK

!   CHECK THAT THE REYNOLDS NUMBER IS IN THE TRANSITION REGION
!   (i.e. 2000<RET<10,000)

IF (RET .GT. 2000.0 .AND. RET .LT. 10000.0) THEN
X1 = RET/1000.0
X2 = 10.0*TID/TL
X3 = (1.0-(X1/10.0)**0.256)
X4 = X2**X3
B1 = (-3.08+3.075*X1+(0.32567*X1**2)-(0.02185*X1**3))*X4
HT = (16.1/TOD)*(B1*TFK*PRT**0.33)
GO TO 110

ELSE IF (RET .GT. 10000.0) THEN
HT = 0.027*TFK*(12.0/TID)*(RET**0.8)*(PRT**0.33)
GO TO 110
ELSE
!      Using the Mills Correlation for longer tubes
HT = (3.66+((0.065*RET*PRT*(TID/TL))/ &
& (1+0.04*(RET*PRT*(TID/TL)**0.67))))*TFK/TID
ENDIF

110 HT    = HT*TID/TOD

!   CALCULATE THE TUBE FRICTION FACTOR

IF (RET .GT. 1000.0) THEN
TFRF = 0.0029/(RET**0.25603)
ELSE
ENDIF

!   CALCULATE THE FLUID VELOCITY, ft./s.

TV = GT/(3600.0*TDEN)

!   CALCULATE THE TUBE SIDE PRESSURE DROP, psi.

TDELP = (TFRF*(GT/3600.0)**2*TL*TNP)/(2.0*G*TDEN*TID/12.0)

!   CALCULATE THE PRESSURE DROP OF RETURN LOSSES, psi.
!   USING FRANK'S CORRELATION.

TRDELP = (2.5*TNP*TDEN*TV**2)/(2*G*144.0)

!   CALCULATE THE TOTAL PRESSURE DROP EXCLUDING THE NOZZLE IN THE
!   TUBE SIDE, psi.

TOTDP = TDELP+TRDELP

RETURN
END

!   ****************************************************************
!   *THIS PROGRAM CALCULATES THE SHELL SIDE HEAT TRANSFER
!   *
!   *COEFFICIENT,
!   REYNOLDS NUMBER, PRANDTL NUMBER, FRICTION FACTOR *
!   *AND PRESSURE DROP.
!   *
!   ****************************************************************

SUBROUTINE SHELL

PARAMETER (PI = 3.1415927, G=32.174)
CHARACTER*30 FTS, FSS
CHARACTER TYPE

COMMON/TUBE1/ FTS, TYPE
COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
COMMON/TUBE4/ TFK, TW
COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
COMMON/TUBE6/ TDELP, TRDELP, TOTDP
COMMON/SHELL1/ FSS
COMMON/SHELL2/ NS, SID, NB, BSP, SFF
COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
COMMON/SHELL4/ SFK, SW
COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
COMMON/SHELL6/ SDELP

COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

REAL NT, NS, NB, LMTD

!   CHECK WHETHER PITCH TYPE IS TRIANGULAR OR SQUARE

IF (TYPE .EQ. 'T' .OR. TYPE .EQ. 't') THEN
DE = ((1.72*TP**2)-(0.5*PI*TOD**2))/(0.5*PI*12.0*TOD)
GO TO 120
ELSE IF (TYPE .EQ. 'S' .OR. TYPE .EQ. 's') THEN
DE = 4.*((TP**2)-(PI*TOD**2/4.0))/(PI*12.0*TOD)
ENDIF

!   CALCULATE THE TUBE CLEARANCE, inch
120    TC = TP-TOD

!   CALCULATE THE SHELL FLOW AREA, ft^2.

IF (NS .GE. 2.0 .AND. NT .GE. 4.0) THEN
SFA = (0.5*(SID*TC*BSP))/(144.0*TP)
GO TO 130
ELSE
SFA = (SID*TC*BSP)/(144.0*TP)
ENDIF

!   CALCULATE THE SHELL SUPERFICIAL FLOW RATE, Ib/ft^2.hr.
130 GS = SW/SFA

!   CALCULATE THE SHELL VELOCITY, ft./sec.
SV = SW/(3600.0*SDEN*SFA)

!   CALCULATE THE REYNOLDS NUMBER
RES = (DE*GS)/(2.42*SVIS)

!   CALCULATE THE PRANDTL NUMBER
PRS = (2.42*SSHC*SVIS)/SFK

!   CALCULATE THE SHELL SIDE HEAT TRANSFER COEFFICIENT
HS = 0.36/DE*SFK*(RES**0.55)*(PRS**0.333)

!   CHECK WHETHER THE SHELL'S REYNOLDS NUMBER IS LESS OR GREATER
!   THAN 500
IF (RES .LT. 500.0) THEN
SFRF = 0.11183/(RES**0.59246)
GO TO 140
ELSEIF (RES .GT. 500.0) THEN
SFRF = 0.01159/(RES**0.18597)
ENDIF

!   CALCULATE THE SHELL SIDE PRESSURE DROP, psi.
140 VAL1 = SFRF*(GS/3600.0)**2*SID/12.0*(NB+1.)
VAL2 = 64.4*SDEN*DE
SDELP = (VAL1/VAL2)*NS

!

RETURN
END

!   ***************************************************************
!   THIS PROGRAM PRINTS THE RESULTS OF THE SHELL AND TUBE HEAT
!   EXCHANGER ONTO A PRINTER
!   ***************************************************************

SUBROUTINE RESULT
CHARACTER*30 FTS,FSS
CHARACTER TYPE

COMMON/TUBE1/ FTS, TYPE
COMMON/TUBE2/ NT, TID, TOD, TP, TL, TNP
COMMON/TUBE3/ TFF, TT1, TT2, TSHC, TVIS, TDEN
COMMON/TUBE4/ TFK, TW
COMMON/TUBE5/ RET, PRT, TFRF, HT, TV
COMMON/TUBE6/ TDELP, TRDELP, TOTDP
COMMON/SHELL1/ FSS
COMMON/SHELL2/ NS, SID, NB, BSP, SFF
COMMON/SHELL3/ TS1, TS2, SSHC, SVIS, SDEN
COMMON/SHELL4/ SFK, SW
COMMON/SHELL5/ RES, PRS, SFRF, HS, SV
COMMON/SHELL6/ SDELP

COMMON/OUT/ Q, AREA, F, LMTD, U, Q1, CMTD

REAL NT, NS, NB, LMTD

WRITE (1, 150)
150 FORMAT (///,18X,'*SHELL AND TUBE HEAT EXCHANGER RATING*')

WRITE (1, 160)
160 FORMAT (78(1H*))

WRITE (1, 170)
170 FORMAT (40X,'TUBE SIDE',10X,'SHELL SIDE')

WRITE (1, 180)
180 FORMAT (78(1H-))

WRITE (1, 190) FTS, FSS
190 FORMAT (2X,'FLUID TYPE:',T40, A15, T60, A15)

WRITE (1, 200) TW, SW
200 FORMAT (2X,'FLUID FLOW RATE , lb/hr.:',T40, F10.0,T60,F10.0)

WRITE (1, 210) TSHC, SSHC
210 FORMAT (2X,'SPECIFIC HEAT CAPACITY, Btu/ib.oF:',T40, F8.3,T60,    &
&     F8.3)

WRITE (1, 220)TDEN, SDEN
220 FORMAT (2X,'FLUID DENSITY, lb/ft^3:',T40,F8.3,T60,F8.3)

WRITE (1, 230) TVIS, SVIS
230 FORMAT (2X,'FLUID VISCOSITY, cP:',T40,F8.3,T60,F8.3)

WRITE (1, 240) TFK, SFK
240 FORMAT (2X,'FLUID THERMAL COND. Btu/ft.h.oF:',T40,F8.3,T60,F8.3)

WRITE (1, 250) TT1, TS1
250 FORMAT (2X,'FLUID INLET TEMPERATURE, oF:',T40,F8.0,T60,F8.0)

WRITE (1, 260) TT2, TS2
260 FORMAT (2X,'FLUID OUTLET TEMPERATURE, oF:',T40,F8.0,T60,F8.0)

WRITE (1, 270) TID, SID
270 FORMAT (2X,'INSIDE DIAMETER, inch:',T40,F8.3,T60,F8.3)

WRITE (1, 280) TOD
280 FORMAT (2X,'OUTSIDE DIAMETER, inch:',T40,F8.3)

IF (TYPE .EQ. 'T' .OR. TYPE .EQ. 't') THEN
WRITE (1, 290) TP
290 FORMAT (2X,'TUBE PITCH, inch:',T40,F8.3,T60,'TRIANGULAR PITCH')
ELSEIF (TYPE .EQ. 'S' .OR. TYPE .EQ. 's') THEN
WRITE (1, 300) TP
300 FORMAT (2X,'TUBE PITCH, inch:',T40,F8.3,T60,'SQUARE PITCH')
ENDIF

WRITE (1, 310) TL
310 FORMAT (2X,'TUBE LENGTH, ft.:',T40,F8.3)

WRITE (1, 315) NT
315 FORMAT (2X,'NUMBER OF TUBES:', T40, F6.0)

WRITE (1, 320) TNP, NS
320 FORMAT (2X,'NUMBER OF PASSES:',T40,F4.0,T60,F4.0)

WRITE (1, 340) NB
340 FORMAT (2X,'NUMBER OF BAFFLES:',T60,F4.0)

WRITE (1, 350) BSP
350 FORMAT (2X,'BAFFLE SPACING, inch:',T60,F4.1)

WRITE (1, 360) TV, SV
360 FORMAT (2X,'FLUID VELOCITY, ft/sec.:',T40,F8.3,T60,F8.3)

WRITE (1, 370) RET, RES
370 FORMAT (2X,'REYNOLDS NUMBER:',T40,F9.0,T60,F9.0)

WRITE (1, 380) PRT, PRS
380 FORMAT (2X,'PRANDTL NUMBER:',T40,F8.4,T60,F8.4)

WRITE (1, 390) TFRF, SFRF
390 FORMAT (2X,'FRICTION FACTOR (ft^2/in^2):',T40,F8.5,T60,F8.5)

WRITE (1, 400) HT, HS
400 FORMAT (2X,'HEAT COEFF., Btu/hr.ft^2.oF:',T40,F9.1,T60,F9.1)

WRITE (1, 410) TOTDP, SDELP
410 FORMAT (2X,'PRESSURE DROP, psi:',T40,F8.4,T60,F8.4)

WRITE (1, 420) TFF, SFF
420 FORMAT (2X,'FOULING FACTOR:',T40,F8.4,T60,F8.4)

WRITE (1, 430) F
430 FORMAT (2X,'APPROACH FACTOR, F:', T40, F8.4)

WRITE (1, 440) LMTD
440    FORMAT (2X,'LOG MEAN TEMP. DIFF. oF:',T40,F8.2)

WRITE (1, 450) CMTD
450    FORMAT (2X,'CORRECTED MEAN TEMP. DIFF. oF:',T40,F8.2)

WRITE (1, 460) U
460    FORMAT (2X,'OVERALL HEAT COEFF., Btu/hr.ft^2.oF:',T40,F9.1)

WRITE (1, 470) AREA
470    FORMAT (2X,'OUTSIDE AREA OF UNIT, ft^2:',T40,F9.1)

WRITE (1, 480) Q
480    FORMAT (2X,'HEAT LOAD ON UNIT, Btu/hr:',T40,F12.0)

WRITE (1, 490) Q1
490    FORMAT (2X,'HEAT TRANSFERRED, Btu/hr:',T40,F12.0)

WRITE (1, 500)
500    FORMAT (1H,78(1H-) )

!   FORM FEED THE PRINTING PAPER TO THE TOP OF THE NEXT PAGE.

WRITE (1, *) CHAR(12)

RETURN
END


FUNCTION func(y)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: y
REAL :: func
!
!  this function is just the equation for a straight line
!  and is used with trapzd.for which performs the integral
!  of this line.  the function is used for the triangular root distribution.
!  other equations for a line can also be used if the distribution
!  is not triangular.
!
func = 0.5*y
!
END FUNCTION func

Project Documents/Source Code Original/Func.f90


PROGRAM test

  USE mpi
  IMPLICIT NONE
  REAL, PARAMETER :: pi = 4.0 * ATAN(1.0)
  INTEGER, PARAMETER :: nels = 1024, nels_t=32
  INTEGER :: nproc, rank, ipp, istart, iend, iloop, errcode
  INTEGER :: iloop2
  REAL, DIMENSION(:), ALLOCATABLE :: x_axis, y_axis
  REAL, DIMENSION(:,:), ALLOCATABLE :: work, final, fsum

  CALL MPI_INIT(errcode)

  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, errcode)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, errcode)

  ipp = nels / nproc
  istart = rank * ipp + 1
  iend = istart + ipp - 1

  ALLOCATE(work(istart:iend, nels_t))
  ALLOCATE(x_axis(istart:iend), y_axis(nels_t))

  !X axis is distributed and runs from 0 to 2 Pi
  DO iloop = istart, iend
    x_axis(iloop) = 2.0*pi/REAL(nels) * REAL(iloop)
  END DO

  !Y axis is not distributed but also runs from 0 to 2 Pi
  DO iloop = 1, nels_t
    y_axis(iloop) = 2.0 * pi / REAL(nels_t) * REAL(iloop)
  END DO

  DO iloop2 = 1, nels_t
    DO iloop = istart, iend
      work(iloop,iloop2) = SIN(x_axis(iloop)) * SIN(y_axis(iloop2))
    END DO
  END DO

  !This isn't a brilliant way of getting data to rank 0
  !but it will work so long as you do a lot of computer before
  !you are finished. Might be better to write one file per processor
  !and stitch them together in post processing
  ALLOCATE(final(1:nels,nels_t), fsum(1:nels, nels_t))
  final = 0.0
  final(istart:iend,:) = work(istart:iend,:)
  CALL MPI_Reduce(final, fsum, nels*nels_t, MPI_REAL, MPI_SUM, &
      0, MPI_COMM_WORLD, errcode)

  IF (rank == 0) THEN
    OPEN(UNIT = 10 , FILE='out.dat', FORM='FORMATTED')
    WRITE(10,*) fsum
    CLOSE(10)
  END IF
  CALL MPI_FINALIZE(errcode)

END PROGRAM test


! https://raw.githubusercontent.com/OpenACC/openacc-interoperability-examples/master/saxpy_openacc_f.f90
module saxpy_mod
  contains
  subroutine saxpy(n, a, x, y)
    integer :: n
    real    :: a, x(:), y(:)
    !$acc parallel deviceptr(x,y)
    y(:) = y(:) + a * x(:)
    !$acc end parallel
  end subroutine
end module


! Copyright (C) 2008-2012 Intel Corporation. All Rights Reserved.
!
! The source code contained or described herein and all documents related to the source code
! ("Material") are owned by Intel Corporation or its suppliers or licensors. Title to the
! Material remains with Intel Corporation or its suppliers and licensors.  The Material is
! protected by worldwide copyright laws and treaty provisions. No part of the Material may be
! used, copied, reproduced, modified, published, uploaded, posted, transmitted, distributed,
! or disclosed in any way except as expressly provided in the license provided with the
! Materials.  No license under any patent, copyright, trade secret or other intellectual
! property right is granted to or conferred upon you by disclosure or delivery of the
! Materials, either expressly, by implication, inducement, estoppel or otherwise, except as
! expressly provided in the license provided with the Materials.
!
program NQueens

! Solve the nqueens problem - serial version
!
! Original C++ code by Ralf Ratering & Mario Deilmann
! Fortran version by Steve Lionel
!
! Read http://en.wikipedia.org/wiki/Nqueens for background
!
! To set command line argument in Visual Studio, right click on the project name and select Properties.
! Under Debugging, enter the argument (board size) in Command Arguments.
!

implicit none

integer :: nrOfSolutions = 0
integer :: size = 0

character(2) :: cmdarg
integer :: stat
integer :: time_start, time_end, count_rate
integer, allocatable :: queens(:)

integer, pointer, dimension(:)  :: correct_solution

integer :: nthreads = 1

allocate(correct_solution(16))
correct_solution = (/ 1,0,0,1,2,10,4,40,92,352,724,2680,14200,73712,365596,2279184 /)

! Get command line argument
if (command_argument_count() < 1) then
  print *, "Usage: threading_issues.exe boardSize"
  size = 10
  print *, "Using default size of 10"
else
  call get_command_argument (1, cmdarg, status=stat)
  if (stat /= 0) then
    print *, "Invalid boardSize"
    stop
  end if
  read (cmdarg,*,iostat=stat) size
  if ((stat /= 0) .or. (size < 1)) then
    print *, "Error: boardSize must be between 1 and 15"
    stop
  end if
  if (size > 15) then
    print *, "Error: boardSize must be between 1 and 15"
    stop
  end if
endif
! Begin
print 101, "Starting nqueens solver for size ", size, &
  " with ", nthreads, " thread(s)"
101 format (A,I0,A,I0,A)
call system_clock (time_start)
allocate (queens(size))
queens = 0
call solve (queens)
call system_clock (time_end, count_rate)
print 101, "Number of solutions: ", nrOfSolutions
if (nrOfSolutions == correct_solution(size+1)) then
  print 101, "Correct Result!"
else
  print 101, "Incorrect Result!"
end if

print 101, "Calculations took ", (time_end-time_start) / (count_rate/1000), "ms."
deallocate (queens)
deallocate (correct_solution)
contains

! Routine to print the board

subroutine print (queens)
  implicit none
  integer, intent(in) :: queens(:)
  integer :: row, col

  do row=1,size
    do col=1,size
      if (queens(row) == col) then
        write (*,'(A)',advance='no') "Q"
      else
        write (*,'(A)',advance='no') "-"
      end if
    end do
  write (*,'(A)')
  end do
write (*,*)
end subroutine print

! Recursive routine to set a queen on the board

recursive subroutine setQueen (queens, row, col)
  implicit none
  integer, intent(inout) :: queens(:)
  integer, intent(in) :: row, col
  integer :: i

  do i=1,row-1
    ! vertical attacks
    if (queens(i) == col) return
    ! diagonal attacks
    if (abs(queens(i)-col) == (row-i)) return
  end do

  ! column is ok, set the queen
  queens(row) = col

  if (row == size) then
    nrOfSolutions = nrOfSolutions + 1
  else
    ! try to fill next row
    do i=1,size
      call setQueen (queens, row+1, i)
    end do
  end if
end subroutine SetQueen

! Main solver routine
subroutine solve (queens)
  implicit none
  integer, intent(inout) :: queens(:)
  integer :: i

  do i=1,size
    ! try all positions in first row
    call SetQueen (queens, 1, i)
  end do
end subroutine solve

end program nQueens


!-------------------------------------------------------------------------------
! uses sequential neural network to learn and predict the 4 cases of the XOR
! function, only utilizing DenseLayers;
! uses one hidden layer with 2 nodes and 1 output node
!-------------------------------------------------------------------------------
! compile: make xor
! run:     ./xor
!-------------------------------------------------------------------------------

program main
    use net_helper_procedures
    use sequential_neural_net
    implicit none

    class(SeqNN), pointer     :: snn
    real(kind=8), allocatable :: X(:,:), Y(:,:), prediction(:,:)
    real(kind=8)              :: loss

    ! hardcode 4 XOR cases
    allocate(X(4,2), Y(4,1))
    X(:,1) = [0,0,1,1] ! A
    X(:,2) = [0,1,0,1] ! B
    Y(:,1) = [0,1,1,0] ! Y = A ^ B

    !---------------------------------------------------------------------------
    ! create network

    snn => create_snn()

    call snn%snn_add_dense_layer(input_nodes = 2, &
                                 out_nodes   = 2, &
                                 activ       = 'elu')

    call snn%snn_add_dense_layer(out_nodes  = 1, &
                                 activ      = 'elu')

    call snn%snn_summary()

    !---------------------------------------------------------------------------
    ! train network

    call snn%snn_fit(dense_input   = X, &
                     target_labels = Y, &
                     batch_size    = 4, &
                     epochs        = 10000, &
                     learn_rate    = 0.4, &
                     loss          = 'mse', &
                     verbose       = 2, &
                     avg_deltas    = .true.)

    !---------------------------------------------------------------------------
    ! check prediction for each case

    call snn%snn_predict(dense_input = X, &
                         res         = prediction)

    print *, '----------------------'
    print *, 'prediction:'
    print *, prediction
    print *, 'actual:'
    print *, Y
    print *, '----------------------'

    !---------------------------------------------------------------------------
    ! check network loss on all predictions

    loss = snn%snn_regression_loss(dense_input   = X, &
                                   target_labels = Y, &
                                   loss          = 'mse')

    print *, '----------------------'
    print *, 'loss:'
    print *, loss
    print *, '----------------------'

    !---------------------------------------------------------------------------

    deallocate(X, Y, prediction)
    call deallocate_snn(snn)
end program


      SUBROUTINE ROOT(T,FT,B,C,RELERR,ABSERR,IFLAG)
C
C  ROOT COMPUTES A ROOT OF THE NONLINEAR EQUATION F(X)=0
C  WHERE F(X) IS A CONTINOUS REAL FUNCTION OF A SINGLE REAL
C  VARIABLE X.  THE METHOD USED IS A COMBINATION OF BISECTION
C  AND THE SECANT RULE.
C
C  NORMAL INPUT CONSISTS OF A CONTINUOS FUNCTION F AND AN
C  INTERVAL (B,C) SUCH THAT F(B)*F(C).LE.0.0.  EACH ITERATION
C  FINDS NEW VALUES OF B AND C SUCH THAT THE INTERVAL(B,C) IS
C  SHRUNK AND F(B)*F(C).LE.0.0.  THE STOPPING CRITERION IS
C
C          DABS(B-C).LE.2.0*(RELERR*DABS(B)+ABSERR)
C
C  WHERE RELERR=RELATIVE ERROR AND ABSERR=ABSOLUTE ERROR ARE
C  INPUT QUANTITIES.  SET THE FLAG, IFLAG, POSITIVE TO INITIALIZE
C  THE COMPUTATION.  AS B,C AND IFLAG ARE USED FOR BOTH INPUT AND
C  OUTPUT, THEY MUST BE VARIABLES IN THE CALLING PROGRAM.
C
C  IF 0 IS A POSSIBLE ROOT, ONE SHOULD NOT CHOOSE ABSERR=0.0.
C
C  THE OUTPUT VALUE OF B IS THE BETTER APPROXIMATION TO A ROOT
C  AS B AND C ARE ALWAYS REDEFINED SO THAT DABS(F(B)).LE.DABS(F(C)).
C
C  TO SOLVE THE EQUATION, ROOT MUST EVALUATE F(X) REPEATEDLY. THIS
C  IS DONE IN THE CALLING PROGRAM.  WHEN AN EVALUATION OF F IS
C  NEEDED AT T, ROOT RETURNS WITH IFLAG NEGATIVE.  EVALUATE FT=F(T)
C  AND CALL ROOT AGAIN.  DO NOT ALTER IFLAG.
C
C  WHEN THE COMPUTATION IS COMPLETE, ROOT RETURNS TO THE CALLING
C  PROGRAM WITH IFLAG POSITIVE=
C
C     IFLAG=1  IF F(B)*F(C).LT.0 AND THE STOPPING CRITERION IS MET.
C
C          =2  IF A VALUE B IS FOUND SUCH THAT THE COMPUTED VALUE
C              F(B) IS EXACTLY ZERO.  THE INTERVAL (B,C) MAY NOT
C              SATISFY THE STOPPING CRITERION.
C
C          =3  IF DABS(F(B)) EXCEEDS THE INPUT VALUES DABS(F(B)),
C              DABS(F(C)).  IN THIS CASE IT IS LIKELY THAT B IS CLOSE
C              TO A POLE OF F.
C
C          =4  IF NO ODD ORDER ROOT WAS FOUND IN THE INTERVAL.  A
C              LOCAL MINIMUM MAY HAVE BEEN OBTAINED.
C
C          =5  IF TOO MANY FUNCTION EVALUATIONS WERE MADE.
C              (AS PROGRAMMED, 500 ARE ALLOWED.)
C
C  THIS CODE IS A MODIFICATION OF THE CODE ZEROIN WHICH IS COMPLETELY
C  EXPLAINED AND DOCUMENTED IN THE TEXT  NUMERICAL COMPUTING:  AN
C  INTRODUCTION,  BY L. F. SHAMPINE AND R. C. ALLEN.
C
C  CALLS  D1MACH .
C
      DOUBLE PRECISION A,ABSERR,ACBS,ACMB,AE,B,C,CMB,D1MACH,FA,FB,
     1  FC,FT,FX,P,Q,RE,RELERR,T,TOL,U
      INTEGER IC,IFLAG,KOUNT
      SAVE
C
      IF(IFLAG.GE.0) GO TO 100
      IFLAG=ABS(IFLAG)
      GO TO (200,300,400), IFLAG
  100 U=D1MACH(4)
      RE=MAX(RELERR,U)
      AE=MAX(ABSERR,0.0D0)
      IC=0
      ACBS=ABS(B-C)
      A=C
      T=A
      IFLAG=-1
      RETURN
  200 FA=FT
      T=B
      IFLAG=-2
      RETURN
  300 FB=FT
      FC=FA
      KOUNT=2
      FX=MAX(ABS(FB),ABS(FC))
    1 IF(ABS(FC).GE.ABS(FB))GO TO 2
C
C  INTERCHANGE B AND C SO THAT ABS(F(B)).LE.ABS(F(C)).
C
      A=B
      FA=FB
      B=C
      FB=FC
      C=A
      FC=FA
    2 CMB=0.5*(C-B)
      ACMB=ABS(CMB)
      TOL=RE*ABS(B)+AE
C
C  TEST STOPPING CRITERION AND FUNCTION COUNT.
C
      IF(ACMB.LE.TOL)GO TO 8
      IF(KOUNT.GE.500)GO TO 12
C
C  CALCULATE NEW ITERATE EXPLICITLY AS B+P/Q
C  WHERE WE ARRANGE P.GE.0.  THE IMPLICIT
C  FORM IS USED TO PREVENT OVERFLOW.
C
      P=(B-A)*FB
      Q=FA-FB
      IF(P.GE.0.0)GO TO 3
      P=-P
      Q=-Q
C
C  UPDATE A, CHECK IF REDUCTION IN THE SIZE OF BRACKETING
C  INTERVAL IS SATISFACTORY.  IF NOT BISECT UNTIL IT IS.
C
    3 A=B
      FA=FB
      IC=IC+1
      IF(IC.LT.4)GO TO 4
      IF(8.0*ACMB.GE.ACBS)GO TO 6
      IC=0
      ACBS=ACMB
C
C  TEST FOR TOO SMALL A CHANGE.
C
    4 IF(P.GT.ABS(Q)*TOL)GO TO 5
C
C  INCREMENT BY TOLERANCE
C
      B=B+SIGN(TOL,CMB)
      GO TO 7
C
C  ROOT OUGHT TO BE BETWEEN B AND (C+B)/2
C
    5 IF(P.GE.CMB*Q)GO TO 6
C
C  USE SECANT RULE.
C
      B=B+P/Q
      GO TO 7
C
C  USE BISECTION.
C
    6 B=0.5*(C+B)
C
C  HAVE COMPLETED COMPUTATION FOR NEW ITERATE B.
C
    7 T=B
      IFLAG=-3
      RETURN
  400 FB=FT
      IF(FB.EQ.0.0)GO TO 9
      KOUNT=KOUNT+1
      IF(SIGN(1.0D0,FB).NE.SIGN(1.0D0,FC))GO TO 1
      C=A
      FC=FA
      GO TO 1
C
C FINISHED.  SET IFLAG.
C
    8 IF(SIGN(1.0D0,FB).EQ.SIGN(1.0D0,FC))GO TO 11
      IF(ABS(FB).GT.FX)GO TO 10
      IFLAG=1
      RETURN
    9 IFLAG=2
      RETURN
   10 IFLAG=3
      RETURN
   11 IFLAG=4
      RETURN
   12 IFLAG=5
      RETURN
      END


subroutine rpn2(ixy, maxm, num_eqn, num_waves, num_aux, num_ghost, &
                num_cells, ql, qr, auxl, auxr, fwave, s, amdq, apdq)

! Normal Riemann solver for the 2D SHALLOW WATER equations
!     with topography:
!     #        h_t + (hu)_x + (hv)_y = 0                           #
!     #        (hu)_t + (hu^2 + 0.5gh^2)_x + (huv)_y = -ghb_x      #
!     #        (hv)_t + (huv)_x + (hv^2 + 0.5gh^2)_y = -ghb_y      #

! This solver is based on David George's solver written for GeoClaw.
! It has been modified to be compatible with f2py (and thus PyClaw).

! waves:     3
! equations: 3

! Conserved quantities:
!       1 depth
!       2 x_momentum
!       3 y_momentum

! Auxiliary fields:
!       1 bathymetry

! The gravitational constant grav should be in the common block cparam.

! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

      implicit none

      real(kind=8) :: grav, g
      real(kind=8), parameter :: drytol = 1.e-14
      common /cparam/ grav

      integer, intent(in) :: maxm,num_eqn,num_aux,num_waves,num_ghost,num_cells,ixy

      real(kind=8), intent(inout) ::  ql(num_eqn, 1-num_ghost:maxm+num_ghost)
      real(kind=8), intent(inout) ::  qr(num_eqn, 1-num_ghost:maxm+num_ghost)
      real(kind=8), intent(in) ::  auxl(num_aux,1-num_ghost:maxm+num_ghost)
      real(kind=8), intent(in) ::  auxr(num_aux,1-num_ghost:maxm+num_ghost)

      real(kind=8), intent(out) :: fwave(num_eqn, num_waves, 1-num_ghost:maxm+num_ghost)
      real(kind=8), intent(out) ::  s(num_waves, 1-num_ghost:maxm+num_ghost)
      real(kind=8), intent(out) ::  apdq(num_eqn,1-num_ghost:maxm+num_ghost)
      real(kind=8), intent(out) ::  amdq(num_eqn,1-num_ghost:maxm+num_ghost)

      !local only
      integer m,i,mw,maxiter,mu,nv
      real(kind=8) wall(3)
      real(kind=8) fw(3,3)
      real(kind=8) sw(3)

      real(kind=8) hR,hL,huR,huL,uR,uL,hvR,hvL,vR,vL,phiR,phiL
      real(kind=8) bR,bL,sL,sR,sRoe1,sRoe2,sE1,sE2,uhat,chat
      real(kind=8) s1m,s2m
      real(kind=8) hstar,hstartest,hstarHLL,sLtest,sRtest
      real(kind=8) tw,dxdc

      logical rare1,rare2

      g = grav

      !loop through Riemann problems at each grid cell
      do i=2-num_ghost,num_cells+num_ghost

      !-----------------------Initializing------------------------------
         !inform of a bad riemann problem from the start
         if((qr(1,i-1).lt.0.d0).or.(ql(1,i) .lt. 0.d0)) then
            write(*,*) 'Negative input: hl,hr,i=',qr(1,i-1),ql(1,i),i
         endif

         !Initialize Riemann problem for grid interface
         do mw=1,num_waves
              s(mw,i)=0.d0
                 fwave(1,mw,i)=0.d0
                 fwave(2,mw,i)=0.d0
                 fwave(3,mw,i)=0.d0
         enddo

!        !set normal direction
         if (ixy.eq.1) then
            mu=2
            nv=3
         else
            mu=3
            nv=2
         endif

         !zero (small) negative values if they exist
         if (qr(1,i-1).lt.0.d0) then
               qr(1,i-1)=0.d0
               qr(2,i-1)=0.d0
               qr(3,i-1)=0.d0
         endif

         if (ql(1,i).lt.0.d0) then
               ql(1,i)=0.d0
               ql(2,i)=0.d0
               ql(3,i)=0.d0
         endif

         !skip problem if in a completely dry area
         if (qr(1,i-1) <= drytol .and. ql(1,i) <= drytol) then
            go to 30
         endif

         !Riemann problem variables
         hL = qr(1,i-1)
         hR = ql(1,i)
         huL = qr(mu,i-1)
         huR = ql(mu,i)
         bL = auxr(1,i-1)
         bR = auxl(1,i)

         hvL=qr(nv,i-1)
         hvR=ql(nv,i)

         !check for wet/dry boundary
         if (hR.gt.drytol) then
            uR=huR/hR
            vR=hvR/hR
            phiR = 0.5d0*g*hR**2 + huR**2/hR
         else
            hR = 0.d0
            huR = 0.d0
            hvR = 0.d0
            uR = 0.d0
            vR = 0.d0
            phiR = 0.d0
         endif

         if (hL.gt.drytol) then
            uL=huL/hL
            vL=hvL/hL
            phiL = 0.5d0*g*hL**2 + huL**2/hL
         else
            hL=0.d0
            huL=0.d0
            hvL=0.d0
            uL=0.d0
            vL=0.d0
            phiL = 0.d0
         endif

         wall(1) = 1.d0
         wall(2) = 1.d0
         wall(3) = 1.d0
         if (hR.le.drytol) then
            call riemanntype(hL,hL,uL,-uL,hstar,s1m,s2m,rare1,rare2,1,drytol,g)
            hstartest=max(hL,hstar)
            if (hstartest+bL.lt.bR) then !right state should become ghost values that mirror left for wall problem
!                bR=hstartest+bL
               wall(2)=0.d0
               wall(3)=0.d0
               hR=hL
               huR=-huL
               bR=bL
               phiR=phiL
               uR=-uL
               vR=vL
            elseif (hL+bL.lt.bR) then
               bR=hL+bL
            endif
         elseif (hL.le.drytol) then ! right surface is lower than left topo
            call riemanntype(hR,hR,-uR,uR,hstar,s1m,s2m,rare1,rare2,1,drytol,g)
            hstartest=max(hR,hstar)
            if (hstartest+bR.lt.bL) then  !left state should become ghost values that mirror right
!               bL=hstartest+bR
               wall(1)=0.d0
               wall(2)=0.d0
               hL=hR
               huL=-huR
               bL=bR
               phiL=phiR
               uL=-uR
               vL=vR
            elseif (hR+bR.lt.bL) then
               bL=hR+bR
            endif
         endif

         !determine wave speeds
         sL=uL-sqrt(g*hL) ! 1 wave speed of left state
         sR=uR+sqrt(g*hR) ! 2 wave speed of right state

         uhat=(sqrt(g*hL)*uL + sqrt(g*hR)*uR)/(sqrt(g*hR)+sqrt(g*hL)) ! Roe average
         chat=sqrt(g*0.5d0*(hR+hL)) ! Roe average
         sRoe1=uhat-chat ! Roe wave speed 1 wave
         sRoe2=uhat+chat ! Roe wave speed 2 wave

         sE1 = min(sL,sRoe1) ! Eindfeldt speed 1 wave
         sE2 = max(sR,sRoe2) ! Eindfeldt speed 2 wave

         !--------------------end initializing...finally----------
         !solve Riemann problem.

         maxiter = 1

         call riemann_aug_JCP(maxiter,3,3,hL,hR,huL, &
              huR,hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2, &
                                          drytol,g,sw,fw)

!        !eliminate ghost fluxes for wall
         do mw=1,3
            sw(mw)=sw(mw)*wall(mw)

               fw(1,mw)=fw(1,mw)*wall(mw)
               fw(2,mw)=fw(2,mw)*wall(mw)
               fw(3,mw)=fw(3,mw)*wall(mw)
         enddo

         do mw=1,num_waves
            s(mw,i)=sw(mw)
            fwave(1,mw,i)=fw(1,mw)
            fwave(mu,mw,i)=fw(2,mw)
            fwave(nv,mw,i)=fw(3,mw)
         enddo

 30      continue
      enddo

!============= compute fluctuations=============================================
         amdq(1:3,:) = 0.d0
         apdq(1:3,:) = 0.d0
         do i=2-num_ghost,num_cells+num_ghost
            do  mw=1,num_waves
               if (s(mw,i) < 0.d0) then
                     amdq(1:3,i) = amdq(1:3,i) + fwave(1:3,mw,i)
               else if (s(mw,i) > 0.d0) then
                  apdq(1:3,i)  = apdq(1:3,i) + fwave(1:3,mw,i)
               else
                 amdq(1:3,i) = amdq(1:3,i) + 0.5d0 * fwave(1:3,mw,i)
                 apdq(1:3,i) = apdq(1:3,i) + 0.5d0 * fwave(1:3,mw,i)
               endif
            enddo
         enddo

      return
      end subroutine

!-----------------------------------------------------------------------
      subroutine riemann_aug_JCP(maxiter,num_eqn,num_waves,hL,hR,huL,huR, &
        hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

      ! solve shallow water equations given single left and right states
      ! This solver is described in J. Comput. Phys. (6): 3089-3113, March 2008
      ! Augmented Riemann Solvers for the Shallow Equations with Steady States and Inundation

      ! To use the original solver call with maxiter=1.

      ! This solver allows iteration when maxiter > 1. The iteration seems to help with
      ! instabilities that arise (with any solver) as flow becomes transcritical over variable topo
      ! due to loss of hyperbolicity.

      implicit none

      !input
      integer num_eqn,num_waves,maxiter
      real(kind=8) fw(num_eqn,num_waves)
      real(kind=8) sw(num_waves)
      real(kind=8) hL,hR,huL,huR,bL,bR,uL,uR,phiL,phiR,sE1,sE2
      real(kind=8) hvL,hvR,vL,vR
      real(kind=8) drytol,g

      !local
      integer m,mw,k,iter
      real(kind=8) A(3,3)
      real(kind=8) r(3,3)
      real(kind=8) lambda(3)
      real(kind=8) del(3)
      real(kind=8) beta(3)

      real(kind=8) delh,delhu,delphi,delb,delnorm
      real(kind=8) rare1st,rare2st,sdelta,raremin,raremax
      real(kind=8) criticaltol,convergencetol,raretol
      real(kind=8) s1s2bar,s1s2tilde,hbar,hLstar,hRstar,hustar
      real(kind=8) huRstar,huLstar,uRstar,uLstar,hstarHLL
      real(kind=8) deldelh,deldelphi
      real(kind=8) s1m,s2m,hm
      real(kind=8) det1,det2,det3,determinant

      logical rare1,rare2,rarecorrector,rarecorrectortest,sonic

      !determine del vectors
      delh = hR-hL
      delhu = huR-huL
      delphi = phiR-phiL
      delb = bR-bL
      delnorm = delh**2 + delphi**2

      call riemanntype(hL,hR,uL,uR,hm,s1m,s2m,rare1,rare2,1,drytol,g)

      lambda(1)= min(sE1,s2m) !Modified Einfeldt speed
      lambda(3)= max(sE2,s1m) !Modified Eindfeldt speed
      sE1=lambda(1)
      sE2=lambda(3)
      lambda(2) = 0.d0  ! ### Fix to avoid uninitialized value in loop on mw -- Correct?? ###

      hstarHLL = max((huL-huR+sE2*hR-sE1*hL)/(sE2-sE1),0.d0) ! middle state in an HLL solve

!     !determine the middle entropy corrector wave------------------------
      rarecorrectortest=.false.
      rarecorrector=.false.
      if (rarecorrectortest) then
         sdelta=lambda(3)-lambda(1)
         raremin = 0.5d0
         raremax = 0.9d0
         if (rare1.and.sE1*s1m.lt.0.d0) raremin=0.2d0
         if (rare2.and.sE2*s2m.lt.0.d0) raremin=0.2d0
         if (rare1.or.rare2) then
            !see which rarefaction is larger
            rare1st=3.d0*(sqrt(g*hL)-sqrt(g*hm))
            rare2st=3.d0*(sqrt(g*hR)-sqrt(g*hm))
            if (max(rare1st,rare2st).gt.raremin*sdelta.and. &
               max(rare1st,rare2st).lt.raremax*sdelta) then
                  rarecorrector=.true.
               if (rare1st.gt.rare2st) then
                  lambda(2)=s1m
               elseif (rare2st.gt.rare1st) then
                  lambda(2)=s2m
               else
                  lambda(2)=0.5d0*(s1m+s2m)
               endif
            endif
         endif
         if (hstarHLL.lt.min(hL,hR)/5.d0) rarecorrector=.false.
      endif

!     ## Is this correct 2-wave when rarecorrector == .true. ??
      do mw=1,num_waves
         r(1,mw)=1.d0
         r(2,mw)=lambda(mw)
         r(3,mw)=(lambda(mw))**2
      enddo
      if (.not.rarecorrector) then
         lambda(2) = 0.5d0*(lambda(1)+lambda(3))
!         lambda(2) = max(min(0.5d0*(s1m+s2m),sE2),sE1)
         r(1,2)=0.d0
         r(2,2)=0.d0
         r(3,2)=1.d0
      endif
!     !---------------------------------------------------

!     !determine the steady state wave -------------------
      criticaltol = 1.d-6
      deldelh = -delb
      deldelphi = -g*0.5d0*(hR+hL)*delb

!     !determine a few quanitites needed for steady state wave if iterated
      hLstar=hL
      hRstar=hR
      uLstar=uL
      uRstar=uR
      huLstar=uLstar*hLstar
      huRstar=uRstar*hRstar

      !iterate to better determine the steady state wave
      convergencetol=1.d-6
      do iter=1,maxiter
         !determine steady state wave (this will be subtracted from the delta vectors)
         if (min(hLstar,hRstar).lt.drytol.and.rarecorrector) then
            rarecorrector=.false.
            hLstar=hL
            hRstar=hR
            uLstar=uL
            uRstar=uR
            huLstar=uLstar*hLstar
            huRstar=uRstar*hRstar
            lambda(2) = 0.5d0*(lambda(1)+lambda(3))
!           lambda(2) = max(min(0.5d0*(s1m+s2m),sE2),sE1)
            r(1,2)=0.d0
            r(2,2)=0.d0
            r(3,2)=1.d0
         endif

         hbar =  max(0.5d0*(hLstar+hRstar),0.d0)
         s1s2bar = 0.25d0*(uLstar+uRstar)**2 - g*hbar
         s1s2tilde= max(0.d0,uLstar*uRstar) - g*hbar

!        !find if sonic problem
         sonic=.false.
         if (abs(s1s2bar).le.criticaltol) sonic=.true.
         if (s1s2bar*s1s2tilde.le.criticaltol) sonic=.true.
         if (s1s2bar*sE1*sE2.le.criticaltol) sonic = .true.
         if (min(abs(sE1),abs(sE2)).lt.criticaltol) sonic=.true.
         if (sE1.lt.0.d0.and.s1m.gt.0.d0) sonic = .true.
         if (sE2.gt.0.d0.and.s2m.lt.0.d0) sonic = .true.
         if ((uL+sqrt(g*hL))*(uR+sqrt(g*hR)).lt.0.d0) sonic=.true.
         if ((uL-sqrt(g*hL))*(uR-sqrt(g*hR)).lt.0.d0) sonic=.true.

!        !find jump in h, deldelh
         if (sonic) then
            deldelh =  -delb
         else
            deldelh = delb*g*hbar/s1s2bar
         endif
!        !find bounds in case of critical state resonance, or negative states
         if (sE1.lt.-criticaltol.and.sE2.gt.criticaltol) then
            deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE2)
            deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE1)
         elseif (sE1.ge.criticaltol) then
            deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE1)
            deldelh = max(deldelh,-hL)
         elseif (sE2.le.-criticaltol) then
            deldelh = min(deldelh,hR)
            deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE2)
         endif

!        !find jump in phi, deldelphi
         if (sonic) then
            deldelphi = -g*hbar*delb
         else
            deldelphi = -delb*g*hbar*s1s2tilde/s1s2bar
         endif
!        !find bounds in case of critical state resonance, or negative states
         deldelphi=min(deldelphi,g*max(-hLstar*delb,-hRstar*delb))
         deldelphi=max(deldelphi,g*min(-hLstar*delb,-hRstar*delb))

         del(1)=delh-deldelh
         del(2)=delhu
         del(3)=delphi-deldelphi

!        !Determine determinant of eigenvector matrix========
         det1=r(1,1)*(r(2,2)*r(3,3)-r(2,3)*r(3,2))
         det2=r(1,2)*(r(2,1)*r(3,3)-r(2,3)*r(3,1))
         det3=r(1,3)*(r(2,1)*r(3,2)-r(2,2)*r(3,1))
         determinant=det1-det2+det3

!        !solve for beta(k) using Cramers Rule=================
         do k=1,3
            do mw=1,3
                  A(1,mw)=r(1,mw)
                  A(2,mw)=r(2,mw)
                  A(3,mw)=r(3,mw)
            enddo
            A(1,k)=del(1)
            A(2,k)=del(2)
            A(3,k)=del(3)
            det1=A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
            det2=A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
            det3=A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
            beta(k)=(det1-det2+det3)/determinant
         enddo

         !exit if things aren't changing
         if (abs(del(1)**2+del(3)**2-delnorm).lt.convergencetol) exit
         delnorm = del(1)**2+del(3)**2
         !find new states qLstar and qRstar on either side of interface
         hLstar=hL
         hRstar=hR
         uLstar=uL
         uRstar=uR
         huLstar=uLstar*hLstar
         huRstar=uRstar*hRstar
         do mw=1,num_waves
            if (lambda(mw).lt.0.d0) then
               hLstar= hLstar + beta(mw)*r(1,mw)
               huLstar= huLstar + beta(mw)*r(2,mw)
            endif
         enddo
         do mw=num_waves,1,-1
            if (lambda(mw).gt.0.d0) then
               hRstar= hRstar - beta(mw)*r(1,mw)
               huRstar= huRstar - beta(mw)*r(2,mw)
            endif
         enddo

         if (hLstar.gt.drytol) then
            uLstar=huLstar/hLstar
         else
            hLstar=max(hLstar,0.d0)
            uLstar=0.d0
         endif
         if (hRstar.gt.drytol) then
            uRstar=huRstar/hRstar
         else
            hRstar=max(hRstar,0.d0)
            uRstar=0.d0
         endif

      enddo ! end iteration on Riemann problem

      do mw=1,num_waves
         sw(mw)=lambda(mw)
         fw(1,mw)=beta(mw)*r(2,mw)
         fw(2,mw)=beta(mw)*r(3,mw)
         fw(3,mw)=beta(mw)*r(2,mw)
      enddo
      !find transverse components (ie huv jumps).
      fw(3,1)=fw(3,1)*vL
      fw(3,3)=fw(3,3)*vR
      fw(3,2)= hR*uR*vR - hL*uL*vL - fw(3,1)- fw(3,3)

      return

      end !subroutine riemann_aug_JCP-------------------------------------------------

!-----------------------------------------------------------------------
      subroutine riemann_ssqfwave(maxiter,num_eqn,num_waves,hL,hR,huL,huR, &
          hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

      ! solve shallow water equations given single left and right states
      ! steady state wave is subtracted from delta [q,f]^T before decomposition

      implicit none

      !input
      integer num_eqn,num_waves,maxiter

      real(kind=8) hL,hR,huL,huR,bL,bR,uL,uR,phiL,phiR,sE1,sE2
      real(kind=8) vL,vR,hvL,hvR
      real(kind=8) drytol,g

      !local
      integer iter

      logical sonic

      real(kind=8) delh,delhu,delphi,delb,delhdecomp,delphidecomp
      real(kind=8) s1s2bar,s1s2tilde,hbar,hLstar,hRstar,hustar
      real(kind=8) uRstar,uLstar,hstarHLL
      real(kind=8) deldelh,deldelphi
      real(kind=8) alpha1,alpha2,beta1,beta2,delalpha1,delalpha2
      real(kind=8) criticaltol,convergencetol
      real(kind=8) sL,sR
      real(kind=8) uhat,chat,sRoe1,sRoe2

      real(kind=8) sw(num_waves)
      real(kind=8) fw(num_eqn,num_waves)

      !determine del vectors
      delh = hR-hL
      delhu = huR-huL
      delphi = phiR-phiL
      delb = bR-bL

      convergencetol= 1.d-16
      criticaltol = 1.d-99

      deldelh = -delb
      deldelphi = -g*0.5d0*(hR+hL)*delb

!     !if no source term, skip determining steady state wave
      if (abs(delb).gt.0.d0) then
!
         !determine a few quanitites needed for steady state wave if iterated
         hLstar=hL
         hRstar=hR
         uLstar=uL
         uRstar=uR
         hstarHLL = max((huL-huR+sE2*hR-sE1*hL)/(sE2-sE1),0.d0) ! middle state in an HLL solve

         alpha1=0.d0
         alpha2=0.d0

!        !iterate to better determine Riemann problem
         do iter=1,maxiter

            !determine steady state wave (this will be subtracted from the delta vectors)
            hbar =  max(0.5d0*(hLstar+hRstar),0.d0)
            s1s2bar = 0.25d0*(uLstar+uRstar)**2 - g*hbar
            s1s2tilde= max(0.d0,uLstar*uRstar) - g*hbar

!           !find if sonic problem
            sonic=.false.
            if (abs(s1s2bar).le.criticaltol) sonic=.true.
            if (s1s2bar*s1s2tilde.le.criticaltol) sonic=.true.
            if (s1s2bar*sE1*sE2.le.criticaltol) sonic = .true.
            if (min(abs(sE1),abs(sE2)).lt.criticaltol) sonic=.true.

!           !find jump in h, deldelh
            if (sonic) then
               deldelh =  -delb
            else
               deldelh = delb*g*hbar/s1s2bar
            endif
!           !bounds in case of critical state resonance, or negative states
            if (sE1.lt.-criticaltol.and.sE2.gt.criticaltol) then
               deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE2)
               deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE1)
            elseif (sE1.ge.criticaltol) then
               deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE1)
               deldelh = max(deldelh,-hL)
            elseif (sE2.le.-criticaltol) then
               deldelh = min(deldelh,hR)
               deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE2)
            endif

!           !find jump in phi, deldelphi
            if (sonic) then
               deldelphi = -g*hbar*delb
            else
               deldelphi = -delb*g*hbar*s1s2tilde/s1s2bar
            endif
!           !bounds in case of critical state resonance, or negative states
            deldelphi=min(deldelphi,g*max(-hLstar*delb,-hRstar*delb))
            deldelphi=max(deldelphi,g*min(-hLstar*delb,-hRstar*delb))

!---------determine fwaves ------------------------------------------

!           !first decomposition
            delhdecomp = delh-deldelh
            delalpha1 = (sE2*delhdecomp - delhu)/(sE2-sE1)-alpha1
            alpha1 = alpha1 + delalpha1
            delalpha2 = (delhu - sE1*delhdecomp)/(sE2-sE1)-alpha2
            alpha2 = alpha2 + delalpha2

            !second decomposition
            delphidecomp = delphi - deldelphi
            beta1 = (sE2*delhu - delphidecomp)/(sE2-sE1)
            beta2 = (delphidecomp - sE1*delhu)/(sE2-sE1)

            if ((delalpha2**2+delalpha1**2).lt.convergencetol**2) then
               exit
            endif
!
            if (sE2.gt.0.d0.and.sE1.lt.0.d0) then
               hLstar=hL+alpha1
               hRstar=hR-alpha2
!               hustar=huL+alpha1*sE1
               hustar = huL + beta1
            elseif (sE1.ge.0.d0) then
               hLstar=hL
               hustar=huL
               hRstar=hR - alpha1 - alpha2
            elseif (sE2.le.0.d0) then
               hRstar=hR
               hustar=huR
               hLstar=hL + alpha1 + alpha2
            endif
!
            if (hLstar.gt.drytol) then
               uLstar=hustar/hLstar
            else
               hLstar=max(hLstar,0.d0)
               uLstar=0.d0
            endif
!
            if (hRstar.gt.drytol) then
               uRstar=hustar/hRstar
            else
               hRstar=max(hRstar,0.d0)
               uRstar=0.d0
            endif

         enddo
      endif

      delhdecomp = delh - deldelh
      delphidecomp = delphi - deldelphi

      !first decomposition
      alpha1 = (sE2*delhdecomp - delhu)/(sE2-sE1)
      alpha2 = (delhu - sE1*delhdecomp)/(sE2-sE1)

      !second decomposition
      beta1 = (sE2*delhu - delphidecomp)/(sE2-sE1)
      beta2 = (delphidecomp - sE1*delhu)/(sE2-sE1)

      ! 1st nonlinear wave
      fw(1,1) = alpha1*sE1
      fw(2,1) = beta1*sE1
      fw(3,1) = fw(1,1)*vL
      ! 2nd nonlinear wave
      fw(1,3) = alpha2*sE2
      fw(2,3) = beta2*sE2
      fw(3,3) = fw(1,3)*vR
      ! advection of transverse wave
      fw(1,2) = 0.d0
      fw(2,2) = 0.d0
      fw(3,2) = hR*uR*vR - hL*uL*vL -fw(3,1)-fw(3,3)
      !speeds
      sw(1)=sE1
      sw(2)=0.5d0*(sE1+sE2)
      sw(3)=sE2

      return

      end subroutine !-------------------------------------------------

!-----------------------------------------------------------------------
      subroutine riemann_fwave(num_eqn,num_waves,hL,hR,huL,huR,hvL,hvR, &
                  bL,bR,uL,uR,vL,vR,phiL,phiR,s1,s2,drytol,g,sw,fw)

      ! solve shallow water equations given single left and right states
      ! solution has two waves.
      ! flux - source is decomposed.

      implicit none

      !input
      integer num_eqn,num_waves

      real(kind=8) hL,hR,huL,huR,bL,bR,uL,uR,phiL,phiR,s1,s2
      real(kind=8) hvL,hvR,vL,vR
      real(kind=8) drytol,g

      real(kind=8) sw(num_waves)
      real(kind=8) fw(num_eqn,num_waves)

      !local
      real(kind=8) delh,delhu,delphi,delb,delhdecomp,delphidecomp
      real(kind=8) deldelh,deldelphi
      real(kind=8) beta1,beta2

      !determine del vectors
      delh = hR-hL
      delhu = huR-huL
      delphi = phiR-phiL
      delb = bR-bL

      deldelphi = -g*0.5d0*(hR+hL)*delb
      delphidecomp = delphi - deldelphi

      !flux decomposition
      beta1 = (s2*delhu - delphidecomp)/(s2-s1)
      beta2 = (delphidecomp - s1*delhu)/(s2-s1)

      sw(1)=s1
      sw(2)=0.5d0*(s1+s2)
      sw(3)=s2
      ! 1st nonlinear wave
      fw(1,1) = beta1
      fw(2,1) = beta1*s1
      fw(3,1) = beta1*vL
      ! 2nd nonlinear wave
      fw(1,3) = beta2
      fw(2,3) = beta2*s2
      fw(3,3) = beta2*vR
      ! advection of transverse wave
      fw(1,2) = 0.d0
      fw(2,2) = 0.d0
      fw(3,2) = hR*uR*vR - hL*uL*vL -fw(3,1)-fw(3,3)
      return

      end !subroutine -------------------------------------------------

!=============================================================================
      subroutine riemanntype(hL,hR,uL,uR,hm,s1m,s2m,rare1,rare2, &
                   maxiter,drytol,g)

      !determine the Riemann structure (wave-type in each family)

      implicit none

      !input
      real(kind=8) hL,hR,uL,uR,drytol,g
      integer maxiter

      !output
      real(kind=8) s1m,s2m
      logical rare1,rare2

      !local
      real(kind=8) hm,u1m,u2m,um,delu
      real(kind=8) h_max,h_min,h0,F_max,F_min,dfdh,F0,slope,gL,gR
      integer iter

!     !Test for Riemann structure

      h_min=min(hR,hL)
      h_max=max(hR,hL)
      delu=uR-uL

      if (h_min.le.drytol) then
         hm=0.d0
         um=0.d0
         s1m=uR+uL-2.d0*sqrt(g*hR)+2.d0*sqrt(g*hL)
         s2m=uR+uL-2.d0*sqrt(g*hR)+2.d0*sqrt(g*hL)
         if (hL.le.0.d0) then
            rare2=.true.
            rare1=.false.
         else
            rare1=.true.
            rare2=.false.
         endif

      else
         F_min= delu+2.d0*(sqrt(g*h_min)-sqrt(g*h_max))
         F_max= delu + (h_max-h_min)*(sqrt(.5d0*g*(h_max+h_min)/(h_max*h_min)))

         if (F_min.gt.0.d0) then !2-rarefactions

            hm=(1.d0/(16.d0*g))* &
                     max(0.d0,-delu+2.d0*(sqrt(g*hL)+sqrt(g*hR)))**2
            um=sign(1.d0,hm)*(uL+2.d0*(sqrt(g*hL)-sqrt(g*hm)))

            s1m=uL+2.d0*sqrt(g*hL)-3.d0*sqrt(g*hm)
            s2m=uR-2.d0*sqrt(g*hR)+3.d0*sqrt(g*hm)

            rare1=.true.
            rare2=.true.

         elseif (F_max.le.0.d0) then !2 shocks

!           !root finding using a Newton iteration on sqrt(h)===
            h0=h_max
            do iter=1,maxiter
               gL=sqrt(.5d0*g*(1/h0 + 1/hL))
               gR=sqrt(.5d0*g*(1/h0 + 1/hR))
               F0=delu+(h0-hL)*gL + (h0-hR)*gR
               dfdh=gL-g*(h0-hL)/(4.d0*(h0**2)*gL)+gR-g*(h0-hR)/(4.d0*(h0**2)*gR)
               slope=2.d0*sqrt(h0)*dfdh
               h0=(sqrt(h0)-F0/slope)**2
            enddo
               hm=h0
               u1m=uL-(hm-hL)*sqrt((.5d0*g)*(1/hm + 1/hL))
               u2m=uR+(hm-hR)*sqrt((.5d0*g)*(1/hm + 1/hR))
               um=.5d0*(u1m+u2m)

               s1m=u1m-sqrt(g*hm)
               s2m=u2m+sqrt(g*hm)
               rare1=.false.
               rare2=.false.

         else !one shock one rarefaction
            h0=h_min

            do iter=1,maxiter
               F0=delu + 2.d0*(sqrt(g*h0)-sqrt(g*h_max)) &
                       + (h0-h_min)*sqrt(.5d0*g*(1/h0+1/h_min))
               slope=(F_max-F0)/(h_max-h_min)
               h0=h0-F0/slope
            enddo

            hm=h0
            if (hL.gt.hR) then
               um=uL+2.d0*sqrt(g*hL)-2.d0*sqrt(g*hm)
               s1m=uL+2.d0*sqrt(g*hL)-3.d0*sqrt(g*hm)
               s2m=uL+2.d0*sqrt(g*hL)-sqrt(g*hm)
               rare1=.true.
               rare2=.false.
            else
               s2m=uR-2.d0*sqrt(g*hR)+3.d0*sqrt(g*hm)
               s1m=uR-2.d0*sqrt(g*hR)+sqrt(g*hm)
               um=uR-2.d0*sqrt(g*hR)+2.d0*sqrt(g*hm)
               rare2=.true.
               rare1=.false.
            endif
         endif
      endif

      return

      end ! subroutine riemanntype----------------------------------------------------------------


module press_and_geopot_mod

! This module provides utilities that computes half- and full-
! level pressure values, given the surface pressure, and
! geopotential heights -- assuming a vertical coordinate in which
! the half level values are p_half(k) = pk(k) + bk(k)*surface_pressure,
! where the constants pk, bk define the coordinate levels.
!
! The full-level values are given by the expression recommended by
! Simmons and Burridge. (See Mon. Weather Review: Vol. 109, No. 4, pp. 758-766)
!  alpha  = 1.0  - p_half(k)*( ln(p_half(k+1)) - ln(p_half(k)) )/(p_half(k+1) - p_half(k))
!  ln(p_full(k)) = ln(p_half(k+1)) - alpha
!
! Geopotentials are computed by assuming isothermal temperatures and in each layer
! integrating the hydrostatic/ideal gas equations exactly

use       fms_mod, only: mpp_pe, mpp_root_pe, error_mesg, FATAL, &
                         write_version_number

use constants_mod, only: grav, rdgas, rvgas

implicit none

private

public :: press_and_geopot_init, press_and_geopot_end, pressure_variables, half_level_pressures
public :: compute_geopotential, compute_pressures_and_heights, compute_z_bot

interface half_level_pressures
   module procedure   half_level_pressures_1d, &
                      half_level_pressures_3d
end interface

interface pressure_variables
   module procedure   pressure_variables_1d, &
                      pressure_variables_3d
end interface

!===============================================================================================

character(len=128), parameter :: version = '$Id: press_and_geopot.f90,v 13.0 2006/03/28 21:17:59 fms Exp $'
character(len=128), parameter :: tagname = '$Name: latest $'

!===============================================================================================

real, allocatable, dimension(:) :: pk, bk
real, allocatable, dimension(:,:) :: surf_geopotential

real    :: ln_top_level_factor
integer :: num_levels
logical :: use_virtual_temperature
character(len=64) :: vert_difference_option

logical :: module_is_initialized = .false.

contains

!------------------------------------------------------------------------------

subroutine press_and_geopot_init(pk_in, bk_in, use_virtual_temperature_in, vert_difference_option_in, surf_geopotential_in)

real,    intent (in), dimension(:)   :: pk_in, bk_in
logical, intent (in)                 :: use_virtual_temperature_in
character(len=*), intent (in)        :: vert_difference_option_in
real,    intent (in), dimension(:,:) :: surf_geopotential_in

if(module_is_initialized) return

call write_version_number(version, tagname)

num_levels = size(pk_in,1)-1

allocate(pk (num_levels+1))
allocate(bk (num_levels+1))
pk = pk_in
bk = bk_in

vert_difference_option  = vert_difference_option_in
use_virtual_temperature = use_virtual_temperature_in

allocate(surf_geopotential(size(surf_geopotential_in,1), size(surf_geopotential_in,2)))
surf_geopotential = surf_geopotential_in

ln_top_level_factor = -1.0

module_is_initialized = .true.

return
end subroutine press_and_geopot_init

!-----------------------------------------------------------------------

function half_level_pressures_3d(surface_p) result(p_half)

real, intent (in),  dimension(:,:)     :: surface_p
real, dimension(size(surface_p,1),size(surface_p,2),num_levels+1) :: p_half

integer :: k

if(.not.module_is_initialized) then
  call error_mesg('half_level_pressures','press_and_geopot_init has not been called', FATAL)
end if

do k=1,num_levels+1
  p_half(:,:,k) = pk(k) + bk(k)*surface_p(:,:)
end do

return
end function half_level_pressures_3d

!-----------------------------------------------------------------------

function half_level_pressures_1d(surface_p) result(p_half)

real, intent (in)             :: surface_p
real, dimension(num_levels+1) :: p_half

integer :: k

do k=1,num_levels+1
  p_half(k) = pk(k)+bk(k)*surface_p
end do

return
end function half_level_pressures_1d

!-------------------------------------------------------------------------------------

subroutine pressure_variables_3d(p_half, ln_p_half, p_full, ln_p_full, surface_p)

real, intent (out), dimension(:,:,:) :: p_half, ln_p_half, p_full, ln_p_full
real, intent (in),  dimension(:,:)   :: surface_p

real, dimension(size(p_half,1),size(p_half,2)) :: alpha

integer :: k

if(.not.module_is_initialized) then
  call error_mesg('pressure_variables','press_and_geopot_init has not been called', FATAL)
end if

p_half = half_level_pressures(surface_p)

if(trim(vert_difference_option) == 'simmons_and_burridge') then

  if(pk(1).eq.0.0 .and. bk(1).eq.0.0) then

    do k=2,size(p_half,3)
      ln_p_half(:,:,k) = log(p_half(:,:,k))
    end do

    do k=2,size(p_half,3)-1
      alpha  = 1.0  - p_half(:,:,k)*(ln_p_half(:,:,k+1) - ln_p_half(:,:,k))/(p_half(:,:,k+1) - p_half(:,:,k))
      ln_p_full(:,:,k) = ln_p_half(:,:,k+1) - alpha
    end do
    ln_p_full(:,:,1) = ln_p_half(:,:,2) + ln_top_level_factor
    ln_p_half(:,:,1) = 0.0

  else

    do k=1,size(p_half,3)
      ln_p_half(:,:,k) = log(p_half(:,:,k))
    end do

    do k=1,size(p_half,3)-1
      alpha  = 1.0  - p_half(:,:,k)*(ln_p_half(:,:,k+1) - ln_p_half(:,:,k))/(p_half(:,:,k+1) - p_half(:,:,k))
      ln_p_full(:,:,k) = ln_p_half(:,:,k+1) - alpha
    end do

  end if
  p_full = exp(ln_p_full)

else if(trim(vert_difference_option) == 'mcm') then

  do k = 1,size(p_full,3)
    p_full   (:,:,k) = 0.5*(p_half(:,:,k+1) + p_half(:,:,k))
    ln_p_full(:,:,k) = log(p_full(:,:,k))
  end do
  if(pk(1).eq.0.0 .and. bk(1).eq.0.0) then
    do k=2,size(p_half,3)
      ln_p_half(:,:,k) = log(p_half(:,:,k))
    end do
    ln_p_half(:,:,1) = 0.
  else
    do k=1,size(p_half,3)
      ln_p_half(:,:,k) = log(p_half(:,:,k))
    end do
  end if

else

  call error_mesg('pressure_variables','"'//trim(vert_difference_option)//'"'// &
                  ' is not a valid value for vert_difference_option', FATAL)

end if

return
end subroutine pressure_variables_3d

!-------------------------------------------------------------------------------------
subroutine compute_z_bot(psg, tg, z_bot, qg)
real, intent(in ), dimension(:,:) :: psg, tg
real, intent(out), dimension(:,:) :: z_bot
real, intent(in ), optional, dimension(:,:) :: qg

real, dimension(size(psg,1), size(psg,2)) ::    p_half_bot,    p_half_nxt
real, dimension(size(psg,1), size(psg,2)) :: ln_p_half_bot, ln_p_half_nxt
real, dimension(size(psg,1), size(psg,2)) :: ln_p_full_bot, alpha, virtual_t

num_levels = size(pk,1) - 1
p_half_bot = pk(num_levels+1) + psg*bk(num_levels+1)
p_half_nxt = pk(num_levels)   + psg*bk(num_levels)
ln_p_half_bot = log(p_half_bot)

if(trim(vert_difference_option) == 'simmons_and_burridge') then
  ln_p_half_nxt = log(p_half_nxt)
  alpha  = 1.0  - p_half_nxt*(ln_p_half_bot - ln_p_half_nxt)/(p_half_bot - p_half_nxt)
  ln_p_full_bot = ln_p_half_bot - alpha
else if(trim(vert_difference_option) == 'mcm') then
  ln_p_full_bot = log(.5*(p_half_bot + p_half_nxt))
endif

if(use_virtual_temperature) then
  if(present(qg)) then
    virtual_t = tg*(1. + (rvgas/rdgas - 1.)*qg)
  else
    call error_mesg('compute_z_bot','qg must be present when use_virtual_temperature=.true.', FATAL)
  endif
else
  virtual_t = tg
endif

z_bot = (rdgas*virtual_t*(ln_p_half_bot - ln_p_full_bot))/grav

return
end subroutine compute_z_bot
!-------------------------------------------------------------------------------------

subroutine pressure_variables_1d(p_half,ln_p_half,p_full,ln_p_full,surface_p)

real, intent (out), dimension(:) :: p_half, ln_p_half, p_full, ln_p_full
real, intent (in)   :: surface_p

real, dimension(1,1)              :: surface_p_2d
real, dimension(1,1,num_levels+1) :: p_half_3d
real, dimension(1,1,num_levels+1) :: ln_p_half_3d
real, dimension(1,1,num_levels)   :: p_full_3d
real, dimension(1,1,num_levels)   :: ln_p_full_3d

surface_p_2d(1,1) = surface_p

call pressure_variables_3d(p_half_3d,ln_p_half_3d,p_full_3d,ln_p_full_3d,surface_p_2d)

p_half    =    p_half_3d(1,1,:)
ln_p_half = ln_p_half_3d(1,1,:)
p_full    =    p_full_3d(1,1,:)
ln_p_full = ln_p_full_3d(1,1,:)

return
end subroutine pressure_variables_1d

!-----------------------------------------------------------------------

subroutine compute_geopotential(t_grid, ln_p_half, ln_p_full, geopot_full, geopot_half, q_grid)

real, intent (in), dimension (:,:,:) :: t_grid, ln_p_half, ln_p_full
real, intent(out), dimension (:,:,:) :: geopot_full, geopot_half
real, intent (in), optional, dimension (:,:,:) :: q_grid

real, dimension (size(t_grid,1),size(t_grid,2),size(t_grid,3)  ) :: virtual_t

integer :: ktop, num_levels, k

if(.not.module_is_initialized) then
  call error_mesg('compute_geopotential','press_and_geopot_init has not been called', FATAL)
end if

num_levels = size(t_grid,3)

geopot_half(:,:,num_levels+1) = surf_geopotential

if(pk(1).eq.0.0) then
  ktop = 2
  geopot_half(:,:,1) = 0.0
else
  ktop = 1
endif

if(use_virtual_temperature) then
  if(present(q_grid)) then
    virtual_t = t_grid*(1. + (rvgas/rdgas - 1.)*q_grid)
  else
    call error_mesg('compute_geopotential','q_grid must be present when use_virtual_temperature=.true.', FATAL)
  endif
else
  virtual_t = t_grid
endif

do k=num_levels,ktop,-1
  geopot_half(:,:,k) = geopot_half(:,:,k+1) + rdgas*virtual_t(:,:,k)*(ln_p_half(:,:,k+1) - ln_p_half(:,:,k))
enddo

do k=1,num_levels
  geopot_full(:,:,k) = geopot_half(:,:,k+1) + rdgas*virtual_t(:,:,k)*(ln_p_half(:,:,k+1) - ln_p_full(:,:,k))
enddo

return
end subroutine compute_geopotential

!-----------------------------------------------------------------------

subroutine compute_pressures_and_heights(t_grid, ps_grid, z_full, z_half, p_full, p_half, q_grid)

real, intent (in), dimension (:,:,:) :: t_grid
real, intent (in), dimension (:,:  ) :: ps_grid
real, intent(in), optional, dimension(:,:,:) :: q_grid

real, intent(out), dimension (size(t_grid,1),size(t_grid,2),size(t_grid,3)  ) :: z_full, p_full
real, intent(out), dimension (size(t_grid,1),size(t_grid,2),size(t_grid,3)+1) :: z_half, p_half

real, dimension(size(t_grid,1),size(t_grid,2),size(t_grid,3)  ) :: ln_p_full
real, dimension(size(t_grid,1),size(t_grid,2),size(t_grid,3)+1) :: ln_p_half

if(.not.module_is_initialized) then
  call error_mesg('compute_pressures_and_heights','press_and_geopot_init has not been called', FATAL)
end if

call pressure_variables (p_half, ln_p_half, p_full, ln_p_full, ps_grid)

call compute_geopotential(t_grid, ln_p_half, ln_p_full, z_full, z_half, q_grid)

z_full = z_full/grav
z_half = z_half/grav

return
end subroutine compute_pressures_and_heights

!-----------------------------------------------------------------------
subroutine press_and_geopot_end

if(.not.module_is_initialized) return

deallocate(pk, bk, surf_geopotential)
module_is_initialized = .false.

return
end subroutine press_and_geopot_end
!-----------------------------------------------------------------------

end module press_and_geopot_mod


( Euler1 in Forth )

: Euler1 RECURSIVE   ( acc n -- r )
    DUP              ( acc n n )
    0= IF            ( acc n )
        DROP         ( acc )

    ELSE
        DUP          ( acc n n )
        3            ( acc n n 3 )
        MOD 0=       ( acc n tf )
        OVER         ( acc n tf n )
        5            ( acc n tf n 5 )
        MOD 0=       ( acc n tf tf )
        OR           ( acc n tf )
        IF           ( acc n )
            SWAP     ( n acc )
            OVER     ( n acc n )
            +        ( n acc+n )
            SWAP     ( acc+n n )
        THEN
        1 -          ( acc n-1 )
        Euler1       ( acc n-1 )
    THEN ;

0 999 Euler1 . BYE


! Copyright (c) 2017-2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_poly
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_cfuns
  Use mlf_utils
  IMPLICIT NONE
  PRIVATE

  Public :: mlf_solve4DPoly, mlf_rootsPoly, mlf_polyFromRoots
  Public :: mlf_polyVal, mlf_polyValDer, DRootsPoly
  Public :: FindRoot2DInterp, FindRoot2PDerivative, FindRoot3Bezier
Contains
  Elemental Real(c_double) Function FindRoot2DInterp(x0, x1, dx1) Result(y)
    ! Evaluate the root of the 2nd order polynomial f with:
    ! f(0) = x0; f(1) = x1; f'(1) = dx1
    real(c_double), intent(in) :: x0, x1, dx1
    real(c_double) :: a, b, z
    a = dx1 - x1 + x0
    If(ABS(a) < 1d-4*ABS(dx1)) Then
      ! 1D interpolation (ignore derivate at 1)
      y = x0/(x0-x1)
      RETURN
    Endif
    b = 1d0 - 0.5d0*dx1/a
    z = SQRT(b**2-x0/a)
    y = b + z ! Choose the root closer to one (if < 1)
    If(y < 1d0) RETURN
    y = b - z
  End Function FindRoot2DInterp

  Integer Function ZRootsQuadratic(R, b, c, eps) Result(nr)
    complex(c_double), intent(in) :: b, c
    complex(c_double), intent(out) :: R(:)
    real(c_double), intent(in) :: eps
    complex(c_double) :: delta
    nr = 0
    delta = 0.25d0*b**2-c
    If(ABS(delta) < eps*ABS(c)) Then
      R(1) = -0.5d0*b
      nr = 1
      RETURN
    Endif
    delta = SQRT(delta)
    R(1) = -0.5d0*b-delta
    R(2) = -0.5d0*b+delta
    nr = 2
  End Function ZRootsQuadratic

  ! Find the solutions of the equation z^3+p*z+q=0
  Integer Function ZRootsCardano(R, p, q, eps) Result(nr)
    complex(c_double), intent(in) :: p, q
    complex(c_double), intent(out) :: R(:)
    real(c_double), intent(in) :: eps
    complex(c_double) :: delta
    complex(c_double) :: a
    integer :: i
    complex(c_double), parameter :: j = (-0.5d0, 8.660254037844386467869d-1)
    nr = 1 ! At least one solution
    If(ABS(q)<eps) Then
      R(1) = (0d0, 0d0)
      If(ABS(p)<eps) RETURN
      nr = 3
      a = SQRT(-p)
      R(2:3) = [a, -a]
      RETURN
    Endif
    If(ABS(p)<eps) Then
      nr = 3
      a = p**(1d0/3d0)
      R(1:3) = [a, a*j, a*j*j]
    Endif
    delta = 1d0/27d0*p**31d0/4d0*q**2
    delta = SQRT(delta)
    a = (delta-0.5d0*q)**(1d0/3d0)
    Do i=1,3
      R(i) = a-p/(3d0*a)
      a = a*j
    End Do
    nr = 3
    ! Remove double solutions
    If(ABS(R(1)-R(3))<eps .OR. ABS(R(2)-R(3))<eps) Then
      nr = 2
    Else If(ABS(R(1)-R(2))<eps) Then
      R(2) = R(3)
      nr = 2
    Endif
  End Function ZRootsCardano

  Integer Function DRootsQuadratic(R, b, c, eps) Result(nr)
    real(c_double), intent(in) :: b, c, eps
    real(c_double), intent(out) :: R(:)
    real(c_double) :: delta
    nr = 0
    delta = 0.25d0*b**2-c
    If(ABS(delta) < eps*ABS(c)) Then
      R(1) = -0.5d0*b
      nr = 1
      RETURN
    Endif
    If(delta<0d0) RETURN
    delta = SQRT(delta)
    R(1) = -0.5d0*b-delta
    R(2) = -0.5d0*b+delta
    nr = 2
  End Function DRootsQuadratic

  ! Find the real solutions of the equation x^3+p*x+q=0
  Integer Function DRootsCardano(R, p, q, eps) Result(nr)
    real(c_double), intent(in) :: p, q, eps
    real(c_double), intent(out) :: R(:)
    real(c_double) :: delta
    complex(c_double) :: a
    complex(c_double), parameter :: j = (-0.5d0, 8.660254037844386467869d-1)
    nr = 1 ! At least one solution
    delta = -4d0*p**3-27d0*q**2
    If(ABS(delta)<eps*ABS(p+q)) Then ! discriminant = 0
      If(ABS(p) < eps) Then ! p == q == 0, so only the solution z=0
        R(1) = 0
      Else
        R(1) = 3d0*q/p
        R(2) = (-3d0*q)/(2d0*p) ! The double root of the equation
        ! So in this case: x^3+p*x+q=(x-R(1)*(x-R(2))^2
        nr = 2
      Endif
      RETURN
    Endif
    If(delta<0) Then ! One real solution (+ 2 complex solutions)
      delta = SQRT(-delta/27d0)
      R(1) = c_cbrt(0.5d0*(-q+delta))+c_cbrt(0.5d0*(-q-delta))
    Else ! Three real solutions
      nr = 3
      a = CMPLX(-0.5d0*q, 0.5*SQRT(delta/27d0), KIND=c_double)**(1d0/3d0)
      ! Get one complex root of (-q+i*sqrt(delta/27))/2
      ! the other complex roots are a*j and a*j^2
      ! The solutions have the form a*j^k+conjg(a*j^k) = 2*real(a*j^k)
      R(1) = 2d0*REAL(a, kind= c_double)
      a = a*j
      R(2) = 2d0*REAL(a, kind= c_double)
      a = a*j
      R(3) = 2d0*REAL(a, kind= c_double)
    Endif
  End Function DRootsCardano

  Real(c_double) Function FindRoot2PTaylorInterpolation(y0, d0, y1, d1) Result(x)
    real(c_double), intent(in) :: y0, d0, y1, d1
    real(c_double) :: a, b, c, d, R(3), eps
    integer :: i, nR
    eps = 1d-30*(MAX(ABS(y0), ABS(y1))/MAX(ABS(d0), ABS(d1)))
    a = d1+d0 - 2*(y1-y0)
    b = y1-y0-d0-a
    If(ABS(a) < eps) Then
      If(ABS(b) < 1d2*ABS(a)) Then
        x = y0/(y0-y1)
        RETURN
      Endif
      nR = DRootsQuadratic(R, d0/b, y0/b, eps)
    Else
      b = b/a; c = d0/a; d = y0/a
      nR = DrootsCardano(R, c-(b**2)/3d0, b/27d0*(2d0*b**2-9d0*c)+d, eps)
      R(1:nR) = R(1:nR) - b/3d0
    Endif
    Do i = 1,nR
      x = R(i)
      If(x > 0 .AND. x < 1) RETURN
    End Do
  End Function FindRoot2PTaylorInterpolation

  Real(c_double) Function FindRoot2PDerivative(y0, d0, y1, d1) Result(x)
    ! Approximate root of a function where f(0)=y0; f'(0)=d0; f(1)=y1; f'(1)=d1
    real(c_double), intent(in) :: y0, d0, y1, d1
    real(c_double) :: dy, m0, m1
    real(c_double) :: a, b, t
    dy = y1-y0
    If(y0 == 0) Then
      x = 0
    Else If(y1 == 1) Then
      x = 1
    Else If(SIGN(y1,y0) == y1) Then
      ! This case is not supported by the algorithm
      x = IEEE_VALUE(x, IEEE_QUIET_NAN)
    Else If(d0 == 0 .AND. d1 == 0) Then
      ! No way to do a proper interpolation so use the secant method instead
      x = -y0/dy
    Else
      ! Main part of the algorithm
      If(ABS(d0) == HUGE(1d0) .OR. ABS(d1) == HUGE(1d0)) Then
        m0 = HUGE(1d0)
      Else
        m0 = MAX(ABS(d0/dy), ABS(d1/dy))
      Endif
      If(d0 == 0d0 .OR. d1 == 0d0) Then
        m1 = HUGE(1d0)
      Else
        m1 = MAX(ABS(dy/d0), ABS(dy/d1))
      Endif
      If(MIN(m0, m1) > 1d8) Then
        ! Use quadrant approximation
        If(ABS(d0/dy) > 1d0) Then
          x = 1-SQRT(1-(y0/dy)**2)
        Else
          x = SQRT(1-(y1/dy)**2)
        Endif
      Else If(m0 < m1) Then
        ! Interpolate p(x) = y with p(0)=y0; p'(0)=d0; p(1)=y1; p'(1)=d1
        x = FindRoot2PTaylorInterpolation(y0, d0, y1, d1)
      Else
        ! Interpolate p(y) = x with p(0)=0; p'(0)=dy/d0; p(1)=1; p'(1)=dy/d1
        ! Rotate, translate and distord the function in order to fit in the square [0;1]²
        m0 = dy/d0
        m1 = dy/d1
        a = m1+m0 - 2
        b = 1-m0-a
        t = -y0/dy
        ! x is the evaluation at p(y0/dy)
        x = t*(m0+t*(b+t*a))
      Endif
    Endif
  End Function FindRoot2PDerivative

  ! Find root of the function using a cubic Bézier's approximation
  ! (Method more stable with vertical curves than a polynomial approximation)
  ! The function is such as f(0) = 0, f(1) = 1, df/dx(0) = d1, df/dx(1) = d2
  ! Return an x such as f(x) = z
  Real(c_double) Function FindRoot3Bezier(d1, d2, z) Result(x)
    real(c_double), intent(in) :: d1, d2, z
    real(c_double) :: P1(2), P2(2), R(3), t
    integer :: i, nR
    ! Use Newton-Raphson step if z is too close to the edges
    If(z < 1d-2*MIN(d1,1d0)) Then
      x = z/d1
      If(x < 0.3d0) RETURN
    Else If(z > 1-1d-2*MIN(d2,1d0)) Then
      x = 1-(1-z)/d2
      If(x > 0.7d0) RETURN
    Endif
    ! P0 = [0,0] and P3 = [1,1]
    ! Compute the remaining two points P1 and P2 of this cubic Bézier curve
    ! so these two points are at distance 1 of respectivly P0 and P3
    ! and they match the derivatives of f
    If(d1 <= 1d0) Then
      P1 = [1d0, d1]
    Else
      P1 = [1d0/d1, 1d0]
    Endif
    P1 = 0.5d0*P1/NORM2(P1)
    If(d2 <= 1d0) Then
      P2 = [1d0, d2]
    Else
      P2 = [1d0/d2, 1d0]
    Endif
    P2 = [1d0, 1d0] - 0.5d0*P2/NORM2(P2)
    ! Polynomial expressing y by t
    ! I prefer to use Cadano's method (Newton-Raphson fail when derivative = 0)
    nR = mlf_rootsPoly([-z, 3*P1(2), 3*P2(2)-6*P1(2), 1-3*P2(2)+3*P1(2)], R, 1d-12)
    Do i = 1, nR
      t = R(i)
      If(R(i) >= 0d0 .AND. R(i) <= 1d0) EXIT
    End Do
    ! Deduce the value of x using t
    x = t*(3*(1-t)*((1-t)*P1(1)+t*P2(1))+t*t)
    ! Avoid x too close to the edge that can stuck the root finding
    x = MIN(MAX(x, z*1d-6), 1-(1-z)*1d-6)
  End Function FindRoot3Bezier

  ! Roots of a depressed quartic using Ferrari's method
  ! TODO: Debug!!
  ! Method too unstable for actual computation! Use DRootsCompanion instead
  Integer Function DRootsFerrari(A, p, q, r, eps) Result(nr)
    real(c_double), intent(in) :: p, q, r, eps
    real(c_double), intent(out) :: A(:)
    real(c_double) :: u, v, mv, R2(3), m
    integer :: i, j
    nr = 0
    mv = MAX(ABS(p), ABS(q), ABS(r))
    If(ABS(q) < eps*mv) Then
      ! Solve x**4+p*x**2+r=0
      j = DRootsQuadratic(R2, p, r, eps)
      Do i=1,j
        If(R2(i) < eps*mv) CYCLE
        If(R2(i) < eps*mv) Then
          nr = nr+1
          A(nr) = 0d0
        Else
          nr = nr+2
          u = SQRT(R2(i))
          A(nr-1:nr) = [-u, u]
        Endif
      End Do
      RETURN
    Endif
    ASSOCIATE(b => p, c => (0.25d0*p**2-r), d => (1d0/8d0*q**2))
      ! Equation P(x)=x^3+b*x^2+c*x+d is transformed in depressed form:
      ! x is replaced by z = x+b/3, so the equation has the form z^3+p*z+q
      j = DRootsCardano(R2, c-(b**2)/3d0, b/27d0*(2d0*b**2-9d0*c)+d, eps)
      R2(1:j) = R2(1:j) - b/3d0 ! x = z-b/3
    END ASSOCIATE
    m = MAXVAL(R2(1:j))
    If(m<-1d-12*mv) RETURN ! No solutions
    If(m<1d-12*mv) Then ! Shall not happen (q /= 0)
      nr = DRootsQuadratic(A, 0d0, 0.5d0*p, eps)
      RETURN
    Endif
    u = SQRT(2d0*m)
    v = 0.5d0*q/u
    nr = DRootsQuadratic(A, u, 0.5d0*p+m-v, eps)
    nr = nr + DRootsQuadratic(A(nr+1:), -u, 0.5d0*p+m+v, eps)
  End Function DRootsFerrari

  ! Classical method for solving the root of a polynomial using a companion Matrix
  Integer Function DRootsCompanion(A, R, eps) result(nr)
    real(c_double), intent(in) :: A(:), eps
    real(c_double), intent(out) :: R(:)
    real(c_double), allocatable :: M(:,:), Work(:), WR(:), WI(:)
    integer :: N, LWORK, INFO, i
    nr = 0
    N = size(A)
    LWORK = N*max(N,11)
    allocate(M(N,N), Work(LWORK), WR(N), WI(N))
    M = 0
    forall(i=1:N-1) M(i+1,i) = 1d0
    M(:,N) = -A
    !call DGEEV('N', 'N', N, M, N, WR, WI, C_NULL_PTR, N, C_NULL_PTR, N, Work, LWORK, INFO)
    call DHSEQR('E', 'N', N, 1, N, M, N, WR, WI, C_NULL_PTR, N, WORK, LWORK, INFO)
    if(info < 0) RETURN
    Do i=N,info+1,-1
      if(abs(WI(i))<eps) then
        nr = nr +1
        R(nr) = WR(i)
      endif
    End Do
  End Function DRootsCompanion

  ! Find real roots of a polynomial
  Integer Function DRootsPoly(A, R, eps) result(nr)
    real(c_double), intent(in) :: A(:), eps
    real(c_double), intent(out) :: R(:)
    real(c_double) :: delta
    integer :: N
    N = SIZE(A)
    nr = 0
    Select Case (N)
      Case(0)
        RETURN
      Case(1)
        R(1) = -A(1)
        nr = 1
      Case(2) ! Solve analytically the second order equation
        nr = DRootsQuadratic(R, A(2), A(1), eps)
      Case(3) ! Use Cardano's method for 3rd order equations
        ASSOCIATE(b => A(3), c => A(2), d => A(1))
          ! Equation P(x)=x^3+b*x^2+c*x+d is transformed in depressed form:
          ! x is replaced by z = x+b/3, so the equation has the form z^3+p*z+q
          nr = DrootsCardano(R, c-(b**2)/3d0, b/27d0*(2d0*b**2-9d0*c)+d, eps)
          R(1:nr) = R(1:nr) - b/3d0 ! x = z-b/3
        END ASSOCIATE
      ! TODO : debug Ferrari's method
      !case(4) ! Use Ferrari's method
      !  ASSOCIATE(b => A(4), c => A(3), d => A(2), e => A(1))
      !    nr = rootsFerrari(R, c-3d0/8d0*b**2, 1d0/8d0*b**3-0.5*b*c+d, &
      !      e-3d0/256d0*b**4-0.25*b*d+1d0/16d0*b**2*c)
      !    R(1:nr) = R(1:nr) - b/4d0
      !  END ASSOCIATE
      Case Default
        ! Use companion matrix to determine polynomial
        nr = DRootsCompanion(A, R, eps)
    End Select
  End Function DRootsPoly

  ! Interface for rootsPoly, check if the top coefficent of A can be negleted
  Integer Function mlf_rootsPoly(A, R, eps) Result(nr)
    real(c_double), intent(in) :: A(:), eps
    real(c_double), intent(out) :: R(:)
    real(c_double) :: m
    integer :: i, j, N
    m = MAXVAL(ABS(A))
    N = SIZE(A)
    nr = 0
    ! Remove head and tail null elements
    Do i=N,1,-1
      If(ABS(A(i)) > m*eps) EXIT
    End Do
    Do j=1,i ! Simplify by X if a_j = 0 (from X^j)
      If(ABS(A(j)) > ABS(A(i))*eps) EXIT
    End Do
    If(i>1) nr = DRootsPoly(A(j:i-1)/A(i), R, eps)
    If(j>1) Then ! If there is null element at tail -> X=0 is a solution
      nr = nr +1
      R(nr) = 0d0
    Endif
  End Function mlf_rootsPoly

  Real(c_double) Function mlf_solve4DPoly(t, a0, a1, a2, a3, a4) Result(x)
    real(c_double), intent(in) :: t, a0, a1, a2, a3, a4
    real(c_double) :: R(4)
    integer :: nr, i, j
    nr = mlf_rootsPoly([a0, a1, a2, a3, a4], R, 1d-12)
    Do i=1,nr
      If(R(i)>t) EXIT
    End Do
    Do j=i+1,nr
      If(R(j)>t .AND. R(j)<R(i)) i = j
    End Do
    If(i>0) Then
      x = R(i)
    Else
      x = IEEE_VALUE(x, IEEE_QUIET_NAN)
    Endif
  End Function mlf_solve4DPoly

  Pure Real(c_double) Function mlf_polyVal(P, x) Result(Y)
    real(c_double), intent(in) :: P(:), x
    integer :: N, i
    N = SIZE(P)
    Y = P(N)
    Do i=N-1,1,-1
      Y = x*Y+P(i)
    End Do
  End Function mlf_polyVal

  Real(c_double) Function mlf_polyValDer(P, x, d) Result(Y)
    real(c_double), intent(in) :: P(:), x
    real(c_double), intent(out) :: d
    integer :: N, i
    N = SIZE(P)
    If(N == 1) Then
      Y = P(N)
      d = 0
      RETURN
    Endif
    Y = P(N)*x+P(N-1)
    d = P(N)
    Do i=N-3,1,-1
      d = Y+d*x
      Y = x*Y+P(i)
    End Do
  End Function mlf_polyValDer

  Subroutine mlf_polyFromRoots(R, P)
    real(c_double), intent(in) :: R(:)
    real(c_double), intent(out) :: P(:)
    real(c_double) :: a
    integer :: k, N
    N = size(R)
    if(N == 1) then
      P(1) = -R(1)
      P(2) = 1d0
      RETURN
    endif
    P(1) = R(1)*R(2)
    P(2) = -R(1)-R(2)
    Do k=3,N
      a = R(k)
      P(k) = P(k-1)-a
      P(2:k-1) = P(1:k-2)-a*P(2:k-1)
      P(1) = -a*P(1)
    End Do
    P(N+1) = 1d0
  End Subroutine mlf_polyFromRoots
End Module mlf_poly


module rational_numbers
  implicit none
contains

  function add(r1,r2)
    integer,dimension(2) :: add, r1,r2
    ! Your code here
  end function

  function sub(r1,r2)
    integer,dimension(2) :: sub, r1,r2
    ! Your code here
  end function

  function mul(r1,r2)
    integer,dimension(2) :: mul, r1,r2
    ! Your code here
  end function

  function div(r1,r2)
    integer,dimension(2) :: div, r1,r2
    ! Your code here
  end function

  function rational_abs(r1)
    integer,dimension(2) :: rational_abs, r1
    ! Your code here
  end function

  function rational_to_pow(r1, ex)
    integer,dimension(2) :: rational_to_pow, r1
    integer :: ex
    ! Your code here
  end function

  function real_to_rational_pow(ex,r1)
    integer,dimension(2) ::  r1
    real :: real_to_rational_pow,ex
    ! Your code here
  end function

  function reduce(r1)
    integer,dimension(2) :: reduce, r1
    ! Your code here
  end function

end module


! { dg-do compile }
! PR fortran/33343
!
! Check conformance of array actual arguments to
! elemental function.
!
! Contributed by Mikael Morin  <mikael.morin@tele2.fr>
!
      module geometry
      implicit none
      integer, parameter :: prec = 8
      integer, parameter :: length = 10
      contains
      elemental function Mul(a, b)
      real(kind=prec) :: a
      real(kind=prec) :: b, Mul
      intent(in)      :: a, b
      Mul = a * b
      end function Mul

      pure subroutine calcdAcc2(vectors, angles)
      real(kind=prec),      dimension(:)          :: vectors
      real(kind=prec), dimension(size(vectors),2) :: angles
      intent(in) :: vectors, angles
      real(kind=prec), dimension(size(vectors)) :: ax
      real(kind=prec), dimension(size(vectors),2) :: tmpAcc
      tmpAcc(1,:) = Mul(angles(1,1:2),ax(1)) ! Ok
      tmpAcc(:,1) = Mul(angles(:,1),ax)      ! OK
      tmpAcc(:,:) = Mul(angles(:,:),ax) ! { dg-error "Incompatible ranks in elemental procedure" }
      end subroutine calcdAcc2
      end module geometry


module numz
  integer, parameter :: b8=selected_real_kind(14)
end module
program stommel
    use numz
    implicit none
    real(b8), allocatable:: psi(:,:)         ! our calculation grid
    real(b8), allocatable:: new_psi(:,:)     ! temp grid
    real(b8) :: diff
    integer nx,ny,ierr,len,stat,i
    character (len=7) :: aline
! the subroutine get_command_argument is part of the Fortran 2003
! standard.  it is accepted by most Fortran compilers as an
! extension.  here, it returns the first command line argument as
! a string "aline" if it is present.  if the program is not given
! any command line arguments then stat indicates an error.
!
! if we have a command line argument then we read from it into the
! integer ierr.  ierr is used to force one of our error conditions.
    call get_command_argument(1, aline, len, stat)
    if(stat .eq. 0)then
      read(aline,*)ierr
    else
      ierr=0
    endif
! set the grid size
    nx=300
    ny=300
! allocate the grid to size nx * ny plus the boundary cells
    allocate(psi(0:nx+1,0:ny+1))
    allocate(new_psi(0:nx+1,0:ny+1))
! set the values of the grid to 1
    psi=1.0
! psi(0,0) we set to zero so that we can force a
! divide by 0.0 later
    psi(0,0)=0.0
! do a jacobian iteration
    call do_jacobi(psi,new_psi,diff,1,nx,1,ny,ierr)
    write(*,"(f12.1)")diff
end program stommel
!*********************
subroutine do_jacobi(psi,new_psi,diff,i1,i2,j1,j2,ierr)
    use numz
    implicit none
    integer,intent(in) :: i1,i2,j1,j2,ierr
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
    real(b8) diff
    real(b8), parameter:: a1=1.0,a2=1.0,a3=1.0,a4=1.0,a5=1.0
    integer i,j
    diff=0.0
    do j=j1,j2
        do i=i1,i2
            new_psi(i,j)=a1*psi(i+1,j) + a2*psi(i-1,j) + &
                         a3*psi(i,j+1) + a4*psi(i,j-1) - &
                         a5*(i+j)
            diff=diff+abs(new_psi(i,j)-psi(i,j))
         enddo
     enddo
! error 1 -- arithmetic error divide by zero
     if(ierr .eq. 1)then
       psi(1,1)=1.0/psi(0,0)
       write(*,*)psi(0,0),psi(1,1)
     endif
! error 2 -- array access out of bounds
     if(ierr .eq. 2)then
       psi(30000,30000)=1.0
     endif
! error 3 -- arithmetic error value out of bounds.  we
!            do this inside of the subroutine asinerror
!            to show another level in our call tree.
     if(ierr .eq. 3)then
       call asinerror(3.0_b8)
     endif
     psi(i1:i2,j1:j2)=new_psi(i1:i2,j1:j2)
end subroutine do_jacobi
!*********************
subroutine asinerror(x)
    use numz
    implicit none
    real(b8) x,y
! error 3 -- arithmetic error value out of bounds
    y=asin(x)
    write(*,*)"asin(",x,") returned ",y
end subroutine


module types
    implicit none
    ! declaration of various parameters I want to use throughout my code to make things simpler

    ! define the parameter dp to represent real*8/double precision to make the code look cleaner
    integer, parameter :: dp = kind(0.d0)

    ! then define another set of paramters that will be useful throughout
    real(dp), parameter :: pi = 4*atan(1.0)
    real(dp), parameter :: c = 299792458.0
    real(dp), parameter :: AU = 1.496e11
    real(dp), parameter :: lsolar = 3.846e26
    real(dp), parameter :: pc = 3.086e16

end module


program main
    implicit none
    real(8), parameter :: R = 13.6
    integer :: Znuc, n, Za
    real(8) :: Ea, Eb, Zb

    open(unit = 1,file = 'approxa.txt',status = 'unknown')
    open(unit = 2,file = 'approxb.txt',status = 'unknown')
    do Znuc = 1,21
        if ((Znuc == 1) .or. (Znuc == 2)) then
            n = 1
            Za = Znuc
            Zb = dble(Znuc) / 2.d0 + 1.d0 / 2.d0
        elseif ((Znuc >= 3) .and. (Znuc <= 10)) then
            n = 2
            Za = Znuc - 2
            Zb = dble(Znuc) / 2.d0 - 1.d0 / 2.d0
        elseif ((Znuc >= 11) .and. (Znuc <= 18)) then
            n = 3
            Za = Znuc - 10
            Zb = dble(Znuc) / 2.d0 - 9.d0 / 2.d0
        elseif ((Znuc == 19) .or. (Znuc == 20)) then
            n = 4
            Za = dble(Znuc) - 18
            Zb = dble(Znuc) / 2.d0 - 19.d0 / 2.d0
        else
            n = 4
            Za = 3
            Zb = 3.d0 / 2.d0
        end if
        Ea = dble(Za)**2 * R / dble(n)**2
        Eb = dble(Zb)**2 * R / dble(n)**2
        write(1,'(i3,f10.4)') Znuc, Ea
        write(2,'(i3,f10.4)') Znuc, Eb
    end do
    close(1)
    close(2)
end program main


! { dg-do compile }
!
! PR 44549: [OOP][F2008] Type-bound procedure: bogus error from list after PROCEDURE
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>

MODULE rational_numbers
  IMPLICIT NONE
  PRIVATE
  TYPE,PUBLIC :: rational
    PRIVATE
    INTEGER n,d

    CONTAINS
    ! ordinary type-bound procedure
    PROCEDURE :: real => rat_to_real
    ! specific type-bound procedures for generic support
    PROCEDURE,PRIVATE :: rat_asgn_i, rat_plus_rat, rat_plus_i
    PROCEDURE,PRIVATE,PASS(b) :: i_plus_rat
    ! generic type-bound procedures
    GENERIC :: ASSIGNMENT(=) => rat_asgn_i
    GENERIC :: OPERATOR(+) => rat_plus_rat, rat_plus_i, i_plus_rat
  END TYPE
  CONTAINS
    ELEMENTAL REAL FUNCTION rat_to_real(this) RESULT(r)
      CLASS(rational),INTENT(IN) :: this
      r = REAL(this%n)/this%d
    END FUNCTION

    impure ELEMENTAL SUBROUTINE rat_asgn_i(a,b)
      CLASS(rational),INTENT(OUT) :: a
      INTEGER,INTENT(IN) :: b
      a%n = b
      a%d = 1
    END SUBROUTINE

    ELEMENTAL TYPE(rational) FUNCTION rat_plus_i(a,b) RESULT(r)
      CLASS(rational),INTENT(IN) :: a
      INTEGER,INTENT(IN) :: b
      r%n = a%n + b*a%d
      r%d = a%d
    END FUNCTION

    ELEMENTAL TYPE(rational) FUNCTION i_plus_rat(a,b) RESULT(r)
      INTEGER,INTENT(IN) :: a
      CLASS(rational),INTENT(IN) :: b
      r%n = b%n + a*b%d
      r%d = b%d
    END FUNCTION

    ELEMENTAL TYPE(rational) FUNCTION rat_plus_rat(a,b) RESULT(r)
      CLASS(rational),INTENT(IN) :: a,b
      r%n = a%n*b%d + b%n*a%d
      r%d = a%d*b%d
    END FUNCTION
END