diff --git a/build/with_fcm/arch/arch-gnu.fcm b/build/with_fcm/arch/arch-gnu.fcm index 5bbff838443dd508f64e32e7f82c863fa38a2d37..f390165536a46d0142ffea354d0595220cfbfa0b 100644 --- a/build/with_fcm/arch/arch-gnu.fcm +++ b/build/with_fcm/arch/arch-gnu.fcm @@ -1,23 +1,23 @@ # Compilation $FCOMPILER = gfortran -$BASE_FFLAGS = -c -fPIC -fdefault-real-8 -fdefault-double-8 -ffree-line-length-none +$BASE_FFLAGS = -c -fPIC -fdefault-real-8 -fdefault-double-8 -ffree-line-length-none -fopenmp -fconvert=swap $PROD_FFLAGS = -O3 $DEV_FFLAGS = -O1 $DEBUG_FFLAGS = -check bounds $CCOMPILER = gcc -$BASE_CFLAGS = -c -fPIC +$BASE_CFLAGS = -c -fPIC -fopenmp $PROD_CFLAGS = -O3 $DEV_CFLAGS = -O1 $DEBUG_CFLAGS = -check bounds $OMP_FFLAGS = # Preprocessor -$FPP_FLAGS = LINUX REPRO48 -$CPP_FLAGS = LINUX +$FPP_FLAGS = LINUX LITTLE_ENDIAN LITTLE REPRO48 +$CPP_FLAGS = LINUX LITTLE_ENDIAN LITTLE # Linker $LINK = gfortran -$BASE_LD = -fPIC -fdefault-real-8 -fdefault-double-8 +$BASE_LD = -fPIC -fdefault-real-8 -fdefault-double-8 -fopenmp $OMP_LD = $LD_EXE_TO_SHARED = -shared diff --git a/build/with_fcm/fcm-make.cfg b/build/with_fcm/fcm-make.cfg index b909baed3e89f53fa1fdeb9267a19ee9df101554..ec0b1d1c141a62c1059c939bb623ae2a71b97a75 100644 --- a/build/with_fcm/fcm-make.cfg +++ b/build/with_fcm/fcm-make.cfg @@ -25,41 +25,46 @@ build.prop{ld} = $LINK build.prop{ar} = $AR ################################################################################################ -# 3 - TARGET +# 3 - TARGETS -############################# -# 3.1 Target definition to build a static lib -#build.target = libphyex.a -#build.target-rename = libo.a:libphyex.a - -############################# -# 3.2 Target definition to build a static lib +#Target definition to build the testprogs programs and a shared lib #We need a shared library (.so) but this cannot be build directly with fcm #The FCM support team says: "FCM doesn’t support building shared libraries." #We use a dummy program to force fcm to use the linker and we add the needed flags #to build a shared library instead of a program -# 3.2.a target is the dummy program but linking is hacked and result is renamed -build.target = libphyex.so +############################# +# 3.1 All programs are built +build.target{task} = link +build.prop{fc.flags-ld} = $LD_FLAGS + +############################# +# 3.2 Special options for specific progam + +# 3.2.a Special treatment for the shared lib +#target is the dummy program but linking is hacked and result is renamed build.target-rename = dummyprog.exe:libphyex.so -build.prop{fc.flags-ld} = $LD_FLAGS $LD_EXE_TO_SHARED +build.prop{fc.flags-ld}[libphyex.so] = $LD_FLAGS $LD_EXE_TO_SHARED +build.prop{dep.o.special}[dummyprog] = $ENTRYPOINTS + +# 3.2.b Special treatment for the testprogs +build.prop{fc.defs}[testprogs] = $FPP_FLAGS WITHOUT_CXXDEMANGLE USE_OPENMP -# 3.2.b dependencies (internal and external) +############################# +# 3.3 dependencies (internal and external) $util = util1 util2 util3 util4 util5 util6 util7 util8 util9 util10 util11 util12 util13 util14 util15 util16 $mpi = mpi2 mpi3 mpi4 mpi5 mpi6 mpi7 mpi8 mpi9 mpi10 mpi11 mpi12 mpi13 mpi14 mpi15 mpi16 mpi17 mpi18 mpi19 $system = system1 system2 system3 system4 system5 system6 system7 system8 system10 system11 system12 system13 system14 build.prop{ns-dep.o} = common parkind drhook $util $mpi oml mpl gstats1 $system build.prop{fc.libs} = $LIBS -# 3.2.c shared lib entry points -build.prop{dep.o.special} = $ENTRYPOINTS - ################################################################################################ # 4 - SOURCES ############################# -# 4.1 Dummy programm to force linking +# 4.1 Programs and dummy programm to force linking build.source[dummyprog] = src/dummyprog.F90 +build.source[testprogs] = src/testprogs ############################# # 4.2 Main directory diff --git a/build/with_fcm/make_fcm.sh b/build/with_fcm/make_fcm.sh index 0b6ed76074544b436dac460655701f0aa1fab1e3..b35776607618964a538c8c2d105a5b0448c6f193 100755 --- a/build/with_fcm/make_fcm.sh +++ b/build/with_fcm/make_fcm.sh @@ -1,5 +1,7 @@ #!/bin/bash +set -e + fcm_version=tags/2021.05.0 fiat_version=1295120464c3905e5edcbb887e4921686653eab8 @@ -182,6 +184,7 @@ cd $builddir mkdir src cd src ln -s ../../../../src/common . +ln -s ../../../../src/testprogs . ln -s ../../fiat/src fiat cat <<EOF > dummyprog.F90 PROGRAM DUMMYPROG diff --git a/src/testprogs/ice_adjust/getdata_mod.F90 b/src/testprogs/ice_adjust/getdata_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..fa2a6ebcffba0b7facf8591c532757ed17a44ae7 --- /dev/null +++ b/src/testprogs/ice_adjust/getdata_mod.F90 @@ -0,0 +1,578 @@ +MODULE GETDATA_MOD + +USE OMP_LIB + +INTERFACE REPLICATE + MODULE PROCEDURE REPLICATE3 + MODULE PROCEDURE REPLICATE4 +END INTERFACE + +INTERFACE NPROMIZE + MODULE PROCEDURE NPROMIZE4 + MODULE PROCEDURE NPROMIZE5 +END INTERFACE + +INTERFACE INTERPOLATE + MODULE PROCEDURE INTERPOLATE4 + MODULE PROCEDURE INTERPOLATE5 +END INTERFACE + +INTERFACE SET + MODULE PROCEDURE SET3 + MODULE PROCEDURE SET4 + MODULE PROCEDURE SET5 +END INTERFACE + +CONTAINS + +SUBROUTINE GETDATA (NPROMA, NGPBLKS, NFLEVG, PRHODJ_B, PEXNREF_B, PRHODREF_B, PPABSM_B, PTHT_B, ZICE_CLD_WGT_B, & +& ZSIGQSAT_B, PSIGS_B, PMFCONV_B, PRC_MF_B, PRI_MF_B, PCF_MF_B, PTHS_B, PRS_B, PSRCS_B, PCLDFR_B, PHLC_HRC_B, PHLC_HCF_B, & +& PHLI_HRI_B, PHLI_HCF_B, ZRS_B, ZZZ_B, PRS_OUT_B, PSRCS_OUT_B, PCLDFR_OUT_B, PHLC_HRC_OUT_B, PHLC_HCF_OUT_B, & +& PHLI_HRI_OUT_B, PHLI_HCF_OUT_B, LDVERBOSE) + +USE IEEE_ARITHMETIC, ONLY : IEEE_SIGNALING_NAN, IEEE_VALUE + +IMPLICIT NONE + +INTEGER, PARAMETER :: IFILE = 77 + +INTEGER :: KLON +INTEGER :: KIDIA +INTEGER :: KFDIA +INTEGER :: KLEV +INTEGER :: KRR +INTEGER :: KDUM + +LOGICAL :: LDVERBOSE + +REAL, ALLOCATABLE :: PRHODJ_B (:,:,:,:) +REAL, ALLOCATABLE :: PEXNREF_B (:,:,:,:) +REAL, ALLOCATABLE :: PRHODREF_B (:,:,:,:) +REAL, ALLOCATABLE :: PPABSM_B (:,:,:,:) +REAL, ALLOCATABLE :: PTHT_B (:,:,:,:) +REAL, ALLOCATABLE :: ZICE_CLD_WGT_B (:,:,:) +REAL, ALLOCATABLE :: ZSIGQSAT_B (:,:,:) +REAL, ALLOCATABLE :: PSIGS_B (:,:,:,:) +REAL, ALLOCATABLE :: PMFCONV_B (:,:,:,:) +REAL, ALLOCATABLE :: PRC_MF_B (:,:,:,:) +REAL, ALLOCATABLE :: PRI_MF_B (:,:,:,:) +REAL, ALLOCATABLE :: PCF_MF_B (:,:,:,:) +REAL, ALLOCATABLE :: PTHS_B (:,:,:,:) +REAL, ALLOCATABLE :: PRS_B (:,:,:,:,:) +REAL, ALLOCATABLE :: PRS_OUT_B (:,:,:,:,:) +REAL, ALLOCATABLE :: PSRCS_B (:,:,:,:) +REAL, ALLOCATABLE :: PSRCS_OUT_B (:,:,:,:) +REAL, ALLOCATABLE :: PCLDFR_B (:,:,:,:) +REAL, ALLOCATABLE :: PCLDFR_OUT_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HRC_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HRC_OUT_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HCF_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HCF_OUT_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HRI_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HRI_OUT_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HCF_B (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HCF_OUT_B (:,:,:,:) +REAL, ALLOCATABLE :: ZRS_B (:,:,:,:,:) +REAL, ALLOCATABLE :: ZZZ_B (:,:,:,:) + +REAL, ALLOCATABLE :: PRHODJ (:,:,:,:) +REAL, ALLOCATABLE :: PEXNREF (:,:,:,:) +REAL, ALLOCATABLE :: PRHODREF (:,:,:,:) +REAL, ALLOCATABLE :: PPABSM (:,:,:,:) +REAL, ALLOCATABLE :: PTHT (:,:,:,:) +REAL, ALLOCATABLE :: PSIGS (:,:,:,:) +REAL, ALLOCATABLE :: PMFCONV (:,:,:,:) +REAL, ALLOCATABLE :: PRC_MF (:,:,:,:) +REAL, ALLOCATABLE :: PRI_MF (:,:,:,:) +REAL, ALLOCATABLE :: PCF_MF (:,:,:,:) +REAL, ALLOCATABLE :: PTHS (:,:,:,:) +REAL, ALLOCATABLE :: PRS (:,:,:,:,:) +REAL, ALLOCATABLE :: PRS_OUT (:,:,:,:,:) +REAL, ALLOCATABLE :: PSRCS_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PCLDFR_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HRC_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HCF_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HRI_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HCF_OUT (:,:,:,:) +REAL, ALLOCATABLE :: ZRS (:,:,:,:,:) +REAL, ALLOCATABLE :: ZZZ (:,:,:,:) + +INTEGER :: NGPTOT, NPROMA, NGPBLKS, NFLEVG +INTEGER :: IOFF, IBL +LOGICAL :: LLEXIST +CHARACTER(LEN=32) :: CLFILE +REAL :: ZNAN + +KRR=6 +NGPTOT = NPROMA * NGPBLKS + +IBL = 1 +WRITE (CLFILE, '("data/",I3.3,".dat")') IBL +OPEN (IFILE, FILE=TRIM (CLFILE), FORM='UNFORMATTED') +READ (IFILE) KLON, KDUM, KLEV +CLOSE (IFILE) + +IF (NFLEVG < 0) NFLEVG = KLEV + +ALLOCATE (ZSIGQSAT_B (NPROMA,1,NGPBLKS)) +ALLOCATE (ZICE_CLD_WGT_B (NPROMA,1,NGPBLKS)) +ALLOCATE (PSRCS_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PCLDFR_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLC_HRC_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLC_HCF_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLI_HRI_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLI_HCF_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PRHODJ_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PEXNREF_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PRHODREF_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PPABSM_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PTHT_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PSIGS_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PMFCONV_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PRC_MF_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PRI_MF_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PCF_MF_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PTHS_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PRS_B (NPROMA,1,NFLEVG,KRR,NGPBLKS)) +ALLOCATE (PRS_OUT_B (NPROMA,1,NFLEVG,KRR,NGPBLKS)) +ALLOCATE (PSRCS_OUT_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PCLDFR_OUT_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (ZRS_B (NPROMA,1,NFLEVG,0:KRR,NGPBLKS)) +ALLOCATE (ZZZ_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLC_HRC_OUT_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLC_HCF_OUT_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLI_HRI_OUT_B (NPROMA,1,NFLEVG,NGPBLKS)) +ALLOCATE (PHLI_HCF_OUT_B (NPROMA,1,NFLEVG,NGPBLKS)) + +ZNAN = IEEE_VALUE (ZNAN, IEEE_SIGNALING_NAN) + + +CALL SET (ZSIGQSAT_B ) +CALL SET (ZICE_CLD_WGT_B) +CALL SET (PSRCS_B ) +CALL SET (PCLDFR_B ) +CALL SET (PHLC_HRC_B ) +CALL SET (PHLC_HCF_B ) +CALL SET (PHLI_HRI_B ) +CALL SET (PHLI_HCF_B ) +CALL SET (PRHODJ_B ) +CALL SET (PEXNREF_B ) +CALL SET (PRHODREF_B ) +CALL SET (PPABSM_B ) +CALL SET (PTHT_B ) +CALL SET (PSIGS_B ) +CALL SET (PMFCONV_B ) +CALL SET (PRC_MF_B ) +CALL SET (PRI_MF_B ) +CALL SET (PCF_MF_B ) +CALL SET (PTHS_B ) +CALL SET (PRS_B ) +CALL SET (PRS_OUT_B ) +CALL SET (PSRCS_OUT_B ) +CALL SET (PCLDFR_OUT_B ) +CALL SET (ZRS_B ) +CALL SET (ZZZ_B ) +CALL SET (PHLC_HRC_OUT_B) +CALL SET (PHLC_HCF_OUT_B) +CALL SET (PHLI_HRI_OUT_B) +CALL SET (PHLI_HCF_OUT_B) + + + +ZSIGQSAT_B = 2.0000000000000000E-002 +ZICE_CLD_WGT_B = 1.5 +PSRCS_B = ZNAN +PCLDFR_B = ZNAN +PHLI_HCF_B = ZNAN +PHLI_HRI_B = ZNAN +PHLC_HCF_B = ZNAN +PHLC_HRC_B = ZNAN + + +IOFF = 0 +IBL = 1 + +DO IBL = 1, 296 + WRITE (CLFILE, '("data/",I3.3,".dat")') IBL + + INQUIRE (FILE=TRIM (CLFILE), EXIST=LLEXIST) + + IF (LDVERBOSE) PRINT *, TRIM (CLFILE) + + IF (.NOT. LLEXIST) EXIT + + OPEN (IFILE, FILE=TRIM (CLFILE), FORM='UNFORMATTED') + + READ (IFILE) KLON, KDUM, KLEV + + IF (IBL == 1) THEN + ALLOCATE (PRHODJ (NGPTOT,1,KLEV,1)) + ALLOCATE (PEXNREF (NGPTOT,1,KLEV,1)) + ALLOCATE (PRHODREF (NGPTOT,1,KLEV,1)) + ALLOCATE (PPABSM (NGPTOT,1,KLEV,1)) + ALLOCATE (PTHT (NGPTOT,1,KLEV,1)) + ALLOCATE (PSIGS (NGPTOT,1,KLEV,1)) + ALLOCATE (PMFCONV (NGPTOT,1,KLEV,1)) + ALLOCATE (PRC_MF (NGPTOT,1,KLEV,1)) + ALLOCATE (PRI_MF (NGPTOT,1,KLEV,1)) + ALLOCATE (PCF_MF (NGPTOT,1,KLEV,1)) + ALLOCATE (PTHS (NGPTOT,1,KLEV,1)) + ALLOCATE (PRS (NGPTOT,1,KLEV,KRR,1)) + ALLOCATE (PRS_OUT (NGPTOT,1,KLEV,KRR,1)) + ALLOCATE (PSRCS_OUT (NGPTOT,1,KLEV,1)) + ALLOCATE (PCLDFR_OUT (NGPTOT,1,KLEV,1)) + ALLOCATE (ZRS (NGPTOT,1,KLEV,0:KRR,1)) + ALLOCATE (ZZZ (NGPTOT,1,KLEV,1)) + ALLOCATE (PHLC_HRC_OUT (NGPTOT,1,KLEV,1)) + ALLOCATE (PHLC_HCF_OUT (NGPTOT,1,KLEV,1)) + ALLOCATE (PHLI_HRI_OUT (NGPTOT,1,KLEV,1)) + ALLOCATE (PHLI_HCF_OUT (NGPTOT,1,KLEV,1)) + ENDIF + + IF (IOFF+KLON > NGPTOT) THEN + EXIT + ENDIF + + READ (IFILE) PRHODJ (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PEXNREF (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PRHODREF (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PSIGS (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PMFCONV (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PPABSM (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) ZZZ (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PCF_MF (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PRC_MF (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PRI_MF (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) ZRS (IOFF+1:IOFF+KLON,:,:,:,1) + READ (IFILE) PRS (IOFF+1:IOFF+KLON,:,:,:,1) + READ (IFILE) PTHS (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PRS_OUT (IOFF+1:IOFF+KLON,:,:,:,1) + READ (IFILE) PSRCS_OUT (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PCLDFR_OUT (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PHLC_HRC_OUT (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PHLC_HCF_OUT (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PHLI_HRI_OUT (IOFF+1:IOFF+KLON,:,:,1) + READ (IFILE) PHLI_HCF_OUT (IOFF+1:IOFF+KLON,:,:,1) + + CLOSE (IFILE) + + IOFF = IOFF + KLON + +ENDDO + +IF (NFLEVG /= KLEV) THEN + CALL INTERPOLATE (NFLEVG, IOFF, PRHODJ ) + CALL INTERPOLATE (NFLEVG, IOFF, PEXNREF ) + CALL INTERPOLATE (NFLEVG, IOFF, PRHODREF ) + CALL INTERPOLATE (NFLEVG, IOFF, PSIGS ) + CALL INTERPOLATE (NFLEVG, IOFF, PMFCONV ) + CALL INTERPOLATE (NFLEVG, IOFF, PPABSM ) + CALL INTERPOLATE (NFLEVG, IOFF, ZZZ ) + CALL INTERPOLATE (NFLEVG, IOFF, PCF_MF ) + CALL INTERPOLATE (NFLEVG, IOFF, PRC_MF ) + CALL INTERPOLATE (NFLEVG, IOFF, PRI_MF ) + CALL INTERPOLATE (NFLEVG, IOFF, ZRS ) + CALL INTERPOLATE (NFLEVG, IOFF, PRS ) + CALL INTERPOLATE (NFLEVG, IOFF, PTHS ) + CALL INTERPOLATE (NFLEVG, IOFF, PRS_OUT ) + CALL INTERPOLATE (NFLEVG, IOFF, PSRCS_OUT ) + CALL INTERPOLATE (NFLEVG, IOFF, PCLDFR_OUT ) + CALL INTERPOLATE (NFLEVG, IOFF, PHLC_HRC_OUT) + CALL INTERPOLATE (NFLEVG, IOFF, PHLC_HCF_OUT) + CALL INTERPOLATE (NFLEVG, IOFF, PHLI_HRI_OUT) + CALL INTERPOLATE (NFLEVG, IOFF, PHLI_HCF_OUT) +ENDIF + +CALL REPLICATE (IOFF, PRHODJ (:, :, :, 1)) +CALL REPLICATE (IOFF, PEXNREF (:, :, :, 1)) +CALL REPLICATE (IOFF, PRHODREF (:, :, :, 1)) +CALL REPLICATE (IOFF, PSIGS (:, :, :, 1)) +CALL REPLICATE (IOFF, PMFCONV (:, :, :, 1)) +CALL REPLICATE (IOFF, PPABSM (:, :, :, 1)) +CALL REPLICATE (IOFF, ZZZ (:, :, :, 1)) +CALL REPLICATE (IOFF, PCF_MF (:, :, :, 1)) +CALL REPLICATE (IOFF, PRC_MF (:, :, :, 1)) +CALL REPLICATE (IOFF, PRI_MF (:, :, :, 1)) +CALL REPLICATE (IOFF, ZRS (:, :, :, :, 1)) +CALL REPLICATE (IOFF, PRS (:, :, :, :, 1)) +CALL REPLICATE (IOFF, PTHS (:, :, :, 1)) +CALL REPLICATE (IOFF, PRS_OUT (:, :, :, :, 1)) +CALL REPLICATE (IOFF, PSRCS_OUT (:, :, :, 1)) +CALL REPLICATE (IOFF, PCLDFR_OUT (:, :, :, 1)) +CALL REPLICATE (IOFF, PHLC_HRC_OUT (:, :, :, 1)) +CALL REPLICATE (IOFF, PHLC_HCF_OUT (:, :, :, 1)) +CALL REPLICATE (IOFF, PHLI_HRI_OUT (:, :, :, 1)) +CALL REPLICATE (IOFF, PHLI_HCF_OUT (:, :, :, 1)) + +CALL NPROMIZE (NPROMA, PRHODJ , PRHODJ_B ) +CALL NPROMIZE (NPROMA, PEXNREF , PEXNREF_B ) +CALL NPROMIZE (NPROMA, PRHODREF , PRHODREF_B ) +CALL NPROMIZE (NPROMA, PSIGS , PSIGS_B ) +CALL NPROMIZE (NPROMA, PMFCONV , PMFCONV_B ) +CALL NPROMIZE (NPROMA, PPABSM , PPABSM_B ) +CALL NPROMIZE (NPROMA, ZZZ , ZZZ_B ) +CALL NPROMIZE (NPROMA, PCF_MF , PCF_MF_B ) +CALL NPROMIZE (NPROMA, PRC_MF , PRC_MF_B ) +CALL NPROMIZE (NPROMA, PRI_MF , PRI_MF_B ) +CALL NPROMIZE (NPROMA, ZRS , ZRS_B ) +CALL NPROMIZE (NPROMA, PRS , PRS_B ) +CALL NPROMIZE (NPROMA, PTHS , PTHS_B ) +CALL NPROMIZE (NPROMA, PRS_OUT , PRS_OUT_B ) +CALL NPROMIZE (NPROMA, PSRCS_OUT , PSRCS_OUT_B ) +CALL NPROMIZE (NPROMA, PCLDFR_OUT , PCLDFR_OUT_B ) +CALL NPROMIZE (NPROMA, PHLC_HRC_OUT, PHLC_HRC_OUT_B ) +CALL NPROMIZE (NPROMA, PHLC_HCF_OUT, PHLC_HCF_OUT_B ) +CALL NPROMIZE (NPROMA, PHLI_HRI_OUT, PHLI_HRI_OUT_B ) +CALL NPROMIZE (NPROMA, PHLI_HCF_OUT, PHLI_HCF_OUT_B ) + +END SUBROUTINE + +SUBROUTINE REPLICATE4 (KOFF, P) + +INTEGER :: KOFF +REAL :: P (:,:,:,:) + +INTEGER :: I, J + +DO I = KOFF+1, SIZE (P, 1) + J = 1 + MODULO (I - 1, KOFF) + P (I, :, :, :) = P (J, :, :, :) +ENDDO + +END SUBROUTINE + +SUBROUTINE REPLICATE3 (KOFF, P) + +INTEGER :: KOFF +REAL :: P (:,:,:) + +INTEGER :: I, J + +DO I = KOFF+1, SIZE (P, 1) + J = 1 + MODULO (I - 1, KOFF) + P (I, :, :) = P (J, :, :) +ENDDO + +END SUBROUTINE + +SUBROUTINE NPROMIZE4 (KPROMA, PI, PO) + +INTEGER :: KPROMA +REAL, INTENT (IN) :: PI (:,:,:,:) +REAL, INTENT (OUT) :: PO (:,:,:,:) + +INTEGER :: I, J, IGPBLK, IGPTOT, IGP, JLON, JIDIA, JFDIA + +IF (SIZE (PI, 4) /= 1) STOP 1 + +IGPTOT = SIZE (PI, 1) +IGPBLK = 1 + (IGPTOT-1) / KPROMA + +DO IGP = 1, IGPTOT, KPROMA + IBL = 1 + (IGP - 1) / KPROMA + JIDIA = 1 + JFDIA = MIN (KPROMA, IGPTOT - (IBL - 1) * KPROMA) + + DO JLON = JIDIA, JFDIA + PO (JLON, :, :, IBL) = PI (IGP + (JLON - 1), :, :, 1) + ENDDO + + DO JLON = JFDIA+1, KPROMA + PO (JLON, :, :, IBL) = PO (JFDIA, :, :, IBL) + ENDDO + +ENDDO + +END SUBROUTINE + +SUBROUTINE NPROMIZE5 (KPROMA, PI, PO) + +INTEGER :: KPROMA +REAL, INTENT (IN) :: PI (:,:,:,:,:) +REAL, INTENT (OUT) :: PO (:,:,:,:,:) + +INTEGER :: I, J, IGPBLK, IGPTOT, IGP, JLON, JIDIA, JFDIA + +IF (SIZE (PI, 5) /= 1) STOP 1 + +IGPTOT = SIZE (PI, 1) +IGPBLK = 1 + (IGPTOT-1) / KPROMA + +DO IGP = 1, IGPTOT, KPROMA + IBL = 1 + (IGP - 1) / KPROMA + JIDIA = 1 + JFDIA = MIN (KPROMA, IGPTOT - (IBL - 1) * KPROMA) + + DO JLON = JIDIA, JFDIA + PO (JLON, :, :, :, IBL) = PI (IGP + (JLON - 1), :, :, :, 1) + ENDDO + + DO JLON = JFDIA+1, KPROMA + PO (JLON, :, :, :, IBL) = PI (JFDIA, :, :, :, IBL) + ENDDO + +ENDDO + +END SUBROUTINE + +SUBROUTINE INTERPOLATE4 (KFLEVG, KOFF, P) + +INTEGER :: KFLEVG, KOFF +REAL, ALLOCATABLE :: P (:,:,:,:) +REAL :: Z (LBOUND (P, 1):UBOUND (P, 1), & + & LBOUND (P, 2):UBOUND (P, 2), & + & LBOUND (P, 3):UBOUND (P, 3), & + & LBOUND (P, 4):UBOUND (P, 4)) +INTEGER :: ILEV1A, ILEV1B, ILEV2, NLEV1, NLEV2 +REAL :: ZWA, ZWB, ZLEV1, ZLEV2 + +Z = P + +NLEV1 = SIZE (P, 3) +NLEV2 = KFLEVG + +DEALLOCATE (P) + +ALLOCATE (P (LBOUND (Z, 1):UBOUND (Z, 1), & + & LBOUND (Z, 2):UBOUND (Z, 2), & + & KFLEVG, & + & LBOUND (Z, 4):UBOUND (Z, 4))) + +DO ILEV2 = 1, NLEV2 + ZLEV2 = REAL (ILEV2 - 1) / REAL (NLEV2 -1) + ZLEV1 = 1. + ZLEV2 * REAL (NLEV1 - 1) + ILEV1B = MIN (CEILING (ZLEV1), NLEV1) + ILEV1A = MAX (FLOOR (ZLEV1), 1) + + IF (ILEV1A == ILEV1B) THEN + ZWA = 1. + ZWB = 0. + ELSE + ZWA = REAL (ILEV1B) - ZLEV1 + ZWB = ZLEV1 - REAL (ILEV1A) + ENDIF + +! WRITE (*, '(" ZLEV2 = ",E12.5," ZLEV1 = ",E12.5," ILEV2 = ",I4," ILEV1A = ",I4," ZWA = ",E12.5," ILEV1B = ",I4," ZWB = ",E12.5)') & +! & ZLEV2, ZLEV1, ILEV2, ILEV1A, ZWA, ILEV1B, ZWB + + P (1:KOFF, :, ILEV2, :) = ZWA * Z (1:KOFF, :, ILEV1A, :) + ZWB * Z (1:KOFF, :, ILEV1B, :) +ENDDO + +END SUBROUTINE + +SUBROUTINE INTERPOLATE5 (KFLEVG, KOFF, P) + +INTEGER :: KFLEVG, KOFF +REAL, ALLOCATABLE :: P (:,:,:,:,:) +REAL :: Z (LBOUND (P, 1):UBOUND (P, 1), & + & LBOUND (P, 2):UBOUND (P, 2), & + & LBOUND (P, 3):UBOUND (P, 3), & + & LBOUND (P, 4):UBOUND (P, 4), & + & LBOUND (P, 5):UBOUND (P, 5)) +INTEGER :: ILEV1A, ILEV1B, ILEV2, NLEV1, NLEV2 +REAL :: ZWA, ZWB, ZLEV1, ZLEV2 + +Z = P + +NLEV1 = SIZE (P, 3) +NLEV2 = KFLEVG + +DEALLOCATE (P) + +ALLOCATE (P (LBOUND (Z, 1):UBOUND (Z, 1), & + & LBOUND (Z, 2):UBOUND (Z, 2), & + & KFLEVG, & + & LBOUND (Z, 4):UBOUND (Z, 4), & + & LBOUND (Z, 5):UBOUND (Z, 5))) + +DO ILEV2 = 1, NLEV2 + ZLEV2 = REAL (ILEV2 - 1) / REAL (NLEV2 -1) + ZLEV1 = 1. + ZLEV2 * REAL (NLEV1 - 1) + ILEV1B = MIN (CEILING (ZLEV1), NLEV1) + ILEV1A = MAX (FLOOR (ZLEV1), 1) + + IF (ILEV1A == ILEV1B) THEN + ZWA = 1. + ZWB = 0. + ELSE + ZWA = REAL (ILEV1B) - ZLEV1 + ZWB = ZLEV1 - REAL (ILEV1A) + ENDIF + +! WRITE (*, '(" ZLEV2 = ",E12.5," ZLEV1 = ",E12.5," ILEV2 = ",I4," ILEV1A = ",I4," ZWA = ",E12.5," ILEV1B = ",I4," ZWB = ",E12.5)') & +! & ZLEV2, ZLEV1, ILEV2, ILEV1A, ZWA, ILEV1B, ZWB + + P (1:KOFF, :, ILEV2, :, :) = ZWA * Z (1:KOFF, :, ILEV1A, :, :) + ZWB * Z (1:KOFF, :, ILEV1B, :, :) +ENDDO + +END SUBROUTINE + +SUBROUTINE SET3 (P) + +REAL :: P (:,:,:) +INTEGER :: IBL, IGPBLKS +INTEGER :: NTID, ITID, JBLK1, JBLK2 + + +IGPBLKS = SIZE (P, 3) + +!$OMP PARALLEL PRIVATE (ITID, JBLK1, JBLK2, NTID) +NTID = OMP_GET_MAX_THREADS () +ITID = OMP_GET_THREAD_NUM () +JBLK1 = 1 + (IGPBLKS * (ITID+0)) / NTID +JBLK2 = (IGPBLKS * (ITID+1)) / NTID + +DO IBL = JBLK1, JBLK2 + P (:,:,IBL) = ZNAN +ENDDO + +!$OMP END PARALLEL + +END SUBROUTINE + +SUBROUTINE SET4 (P) + +REAL :: P (:,:,:,:) +INTEGER :: IBL, IGPBLKS +INTEGER :: NTID, ITID, JBLK1, JBLK2 + +IGPBLKS = SIZE (P, 4) + +!$OMP PARALLEL PRIVATE (ITID, JBLK1, JBLK2, NTID) +NTID = OMP_GET_MAX_THREADS () +ITID = OMP_GET_THREAD_NUM () +JBLK1 = 1 + (IGPBLKS * (ITID+0)) / NTID +JBLK2 = (IGPBLKS * (ITID+1)) / NTID + +DO IBL = JBLK1, JBLK2 + P (:,:,:,IBL) = ZNAN +ENDDO + +!$OMP END PARALLEL + +END SUBROUTINE + +SUBROUTINE SET5 (P) + +REAL :: P (:,:,:,:,:) +INTEGER :: IBL, IGPBLKS +INTEGER :: NTID, ITID, JBLK1, JBLK2 + +IGPBLKS = SIZE (P, 5) + +!$OMP PARALLEL PRIVATE (ITID, JBLK1, JBLK2, NTID) +NTID = OMP_GET_MAX_THREADS () +ITID = OMP_GET_THREAD_NUM () +JBLK1 = 1 + (IGPBLKS * (ITID+0)) / NTID +JBLK2 = (IGPBLKS * (ITID+1)) / NTID + +DO IBL = JBLK1, JBLK2 + P (:,:,:,:,IBL) = ZNAN +ENDDO + +!$OMP END PARALLEL + +END SUBROUTINE + + +END MODULE diff --git a/src/testprogs/ice_adjust/main_ice_adjust.F90 b/src/testprogs/ice_adjust/main_ice_adjust.F90 new file mode 100644 index 0000000000000000000000000000000000000000..27dd585df56ee50b7320b9f1001593f004760eb0 --- /dev/null +++ b/src/testprogs/ice_adjust/main_ice_adjust.F90 @@ -0,0 +1,369 @@ +PROGRAM MAIN_ICE_ADJUST + +USE XRD_GETOPTIONS +USE GETDATA_MOD +USE MODI_ICE_ADJUST +USE MODD_DIMPHYEX, ONLY: DIMPHYEX_t +USE MODD_CST, ONLY: CST_t, CST +USE MODD_NEB, ONLY: NEB_t, NEB +USE MODD_RAIN_ICE_PARAM, ONLY : RAIN_ICE_PARAM_t +USE MODI_INI_CST +USE MODI_INI_NEB +USE MODD_BUDGET, ONLY: TBUDGETDATA, NBUDGET_RI, TBUCONF +USE STACK_MOD +USE OMP_LIB +USE YOMHOOK, ONLY : LHOOK, DR_HOOK +USE PARKIND1, ONLY : JPRB, JPIM + + +IMPLICIT NONE + +INTEGER :: KLON +INTEGER :: KIDIA +INTEGER :: KFDIA +INTEGER :: KLEV +INTEGER :: KRR + +REAL, ALLOCATABLE :: PRHODJ (:,:,:,:) +REAL, ALLOCATABLE :: PEXNREF (:,:,:,:) +REAL, ALLOCATABLE :: PRHODREF (:,:,:,:) +REAL, ALLOCATABLE :: PPABSM (:,:,:,:) +REAL, ALLOCATABLE :: PTHT (:,:,:,:) +REAL, ALLOCATABLE :: PSIGS (:,:,:,:) +REAL, ALLOCATABLE :: PMFCONV (:,:,:,:) +REAL, ALLOCATABLE :: PRC_MF (:,:,:,:) +REAL, ALLOCATABLE :: PRI_MF (:,:,:,:) +REAL, ALLOCATABLE :: PCF_MF (:,:,:,:) +REAL, ALLOCATABLE :: PTHS (:,:,:,:) +REAL, ALLOCATABLE :: PRS (:,:,:,:,:) +REAL, ALLOCATABLE :: PSRCS (:,:,:,:) +REAL, ALLOCATABLE :: PCLDFR (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HRC (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HCF (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HRI (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HCF (:,:,:,:) +REAL, ALLOCATABLE :: ZRS (:,:,:,:,:) +REAL, ALLOCATABLE :: ZZZ (:,:,:,:) +REAL, ALLOCATABLE :: ZSIGQSAT (:,:,:) +REAL, ALLOCATABLE :: ZICE_CLD_WGT (:,:,:) + +REAL, ALLOCATABLE :: PRS_OUT (:,:,:,:,:) +REAL, ALLOCATABLE :: PSRCS_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PCLDFR_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HRC_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLC_HCF_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HRI_OUT (:,:,:,:) +REAL, ALLOCATABLE :: PHLI_HCF_OUT (:,:,:,:) + +INTEGER :: NPROMA, NGPBLKS, NFLEVG +INTEGER :: IBL, JLON, JLEV + +TYPE(DIMPHYEX_t) :: D, D0 +TYPE(RAIN_ICE_PARAM_t) :: ICEP +CHARACTER(LEN=1) :: HFRAC_ICE +CHARACTER(LEN=80) :: HCONDENS +CHARACTER(LEN=4) :: HLAMBDA3 +CHARACTER(LEN=4) :: HBUNAME +LOGICAL :: OSUBG_COND +LOGICAL :: OSIGMAS +LOGICAL :: OCND2 +LOGICAL :: LMFCONV +CHARACTER(LEN=80) :: HSUBG_MF_PDF +REAL :: PTSTEP +TYPE(TBUDGETDATA), DIMENSION(NBUDGET_RI) :: YLBUDGET +LOGICAL :: LLCHECK +LOGICAL :: LLCHECKDIFF +LOGICAL :: LLDIFF +INTEGER :: IBLOCK1, IBLOCK2 +INTEGER :: ISTSZ, JBLK1, JBLK2 +INTEGER :: NTID, ITID +INTEGER :: JRR + +REAL, ALLOCATABLE :: PSTACK(:,:) +TYPE (STACK) :: YLSTACK + +REAL(KIND=8) :: TS,TE +REAL(KIND=8) :: TSC, TEC, TSD, TED, ZTC, ZTD +INTEGER :: ITIME, NTIME +INTEGER :: IRANK, ISIZE +LOGICAL :: LLVERBOSE, LLSTAT, LLBIND +REAL (KIND=JPRB) :: ZHOOK_HANDLE + +CALL INITOPTIONS () +NGPBLKS = 296 +CALL GETOPTION ("--blocks", NGPBLKS) +NPROMA = 32 +CALL GETOPTION ("--nproma", NPROMA) +NFLEVG = -1 +CALL GETOPTION ("--nflevg", NFLEVG) +CALL GETOPTION ("--check", LLCHECK) +CALL GETOPTION ("--checkdiff", LLCHECKDIFF) +IBLOCK1 = 1 +CALL GETOPTION ("--check-block-1", IBLOCK1) +IBLOCK2 = NGPBLKS +CALL GETOPTION ("--check-block-2", IBLOCK2) +CALL GETOPTION ("--stat", LLSTAT) +NTIME = 1 +CALL GETOPTION ("--times", NTIME) +CALL GETOPTION ("--verbose", LLVERBOSE) +CALL GETOPTION ("--bind", LLBIND) +CALL CHECKOPTIONS () + +LLDIFF = .FALSE. + +IRANK = 0 +ISIZE = 1 +IF (LLBIND) THEN + CALL LINUX_BIND (IRANK, ISIZE) + CALL LINUX_BIND_DUMP (IRANK, ISIZE) +ENDIF + +CALL GETDATA (NPROMA, NGPBLKS, NFLEVG, PRHODJ, PEXNREF, PRHODREF, PPABSM, PTHT, ZICE_CLD_WGT, & +& ZSIGQSAT, PSIGS, PMFCONV, PRC_MF, PRI_MF, PCF_MF, PTHS, PRS, PSRCS, PCLDFR, PHLC_HRC, PHLC_HCF, & +& PHLI_HRI, PHLI_HCF, ZRS, ZZZ, PRS_OUT, PSRCS_OUT, PCLDFR_OUT, PHLC_HRC_OUT, PHLC_HCF_OUT, & +& PHLI_HRI_OUT, PHLI_HCF_OUT, LLVERBOSE) + + +KLEV = SIZE (PRS, 3) +KRR = SIZE (PRS, 4) + +IF (LLVERBOSE) PRINT *, " KLEV = ", KLEV, " KRR = ", KRR + +PRINT *, " NPROMA = ", NPROMA, " KLEV = ", KLEV, " NGPBLKS = ", NGPBLKS + +CALL INI_CST +CALL INI_NEB + +! Taken from ini_rain_ice.F90; we only need these for ice_adjust.F90 +ICEP%XCRIAUTI = 0.2E-4 +ICEP%XCRIAUTC = 0.5E-3 +ICEP%XACRIAUTI = 0.06 +ICEP%XBCRIAUTI = -3.5 + +! As provided by S. Riette, AROME specific + +ICEP%XCRIAUTC = 1.0000000000000000E-003 +ICEP%XCRIAUTI = 2.0000000000000001E-004 +ICEP%XACRIAUTI = 6.2974856647312144E-002 +ICEP%XBCRIAUTI = -3.3840957210994582 + + +HFRAC_ICE = 'S' +HCONDENS = 'CB02' +HLAMBDA3 = 'CB' +HBUNAME = 'DEPI' +OSUBG_COND = .TRUE. +OSIGMAS = .TRUE. +OCND2 = .FALSE. +HSUBG_MF_PDF = 'TRIANGLE' +PTSTEP = 50.000000000000000 +LMFCONV = .TRUE. +DO JRR=1, NBUDGET_RI + YLBUDGET(JRR)%NBUDGET=JRR +ENDDO + +D0%NIT = NPROMA +D0%NIB = 1 +D0%NIE = NPROMA +D0%NJT = 1 +D0%NJB = 1 +D0%NJE = 1 +D0%NKL = -1 +D0%NKT = KLEV +D0%NKA = KLEV +D0%NKU = 1 +D0%NKB = KLEV +D0%NKE = 1 +D0%NKTB = 1 +D0%NKTE = KLEV + +ISTSZ = NPROMA * 20 * KLEV +ALLOCATE (PSTACK (ISTSZ, NGPBLKS)) + +TS = OMP_GET_WTIME () + +ZTD = 0. +ZTC = 0. + +IF (LHOOK) CALL DR_HOOK ('MAIN',0,ZHOOK_HANDLE) + +DO ITIME = 1, NTIME + + TSD = OMP_GET_WTIME () + +!$acc data & +!$acc & copyin (D0, CST, ICEP, NEB, KRR, HFRAC_ICE, HCONDENS, HLAMBDA3, HBUNAME, OSUBG_COND, OSIGMAS, OCND2, HSUBG_MF_PDF, PTSTEP, LMFCONV, & +!$acc & ZSIGQSAT, PRHODJ, PEXNREF, PRHODREF, PSIGS, PMFCONV, PPABSM, ZZZ, PCF_MF, PRC_MF, PRI_MF, ZRS, ZICE_CLD_WGT) & +!$acc & copy (PRS, PTHS), & +!$acc & copyout (PSRCS, PCLDFR, PHLC_HRC, PHLC_HCF, PHLI_HRI, PHLI_HCF) & +!$acc & create (PSTACK) + + TSC = OMP_GET_WTIME () + +#ifdef USE_OPENMP +!$OMP PARALLEL PRIVATE (D, ITID, JBLK1, JBLK2) +#endif + +#ifdef _OPENACC +JBLK1 = 1 +JBLK2 = NGPBLKS +#endif + +#ifdef USE_OPENMP +NTID = OMP_GET_MAX_THREADS () +ITID = OMP_GET_THREAD_NUM () +JBLK1 = 1 + (NGPBLKS * (ITID+0)) / NTID +JBLK2 = (NGPBLKS * (ITID+1)) / NTID + + +!PRINT *, ITID, JBLK1, JBLK2 + +#endif + +!$acc parallel loop gang vector private (YLSTACK, IBL, JLON, D) collapse (2) + + DO IBL = JBLK1, JBLK2 + + +#ifdef _OPENACC + DO JLON = 1, NPROMA + D = D0 + D%NIB = JLON + D%NIE = JLON +#endif + +#ifdef USE_OPENMP + D = D0 +#endif + +#ifdef USE_STACK + YLSTACK%L = LOC (PSTACK (1, IBL)) + YLSTACK%U = YLSTACK%L + ISTSZ * KIND (PSTACK) +#else + YLSTACK%L = 0 + YLSTACK%U = 0 +#endif + + CALL ICE_ADJUST (D, CST, ICEP, NEB, TBUCONF, KRR, HFRAC_ICE, HCONDENS, HLAMBDA3, HBUNAME, OSUBG_COND, & + & OSIGMAS, OCND2, HSUBG_MF_PDF, PTSTEP, ZSIGQSAT (:, :, IBL), PRHODJ=PRHODJ (:, :, :, IBL), PEXNREF=PEXNREF (:, :, :, IBL), & + & PRHODREF=PRHODREF (:, :, :, IBL), PSIGS=PSIGS (:, :, :, IBL), LMFCONV=LMFCONV, PMFCONV=PMFCONV (:, :, :, IBL), & + & PPABST=PPABSM (:, :, :, IBL), PZZ=ZZZ (:, :, :, IBL), PEXN=PEXNREF (:, :, :, IBL), PCF_MF=PCF_MF (:, :, :, IBL), & + & PRC_MF=PRC_MF (:, :, :, IBL), PRI_MF=PRI_MF (:, :, :, IBL), PRV=ZRS(:, :, :, 1, IBL), PRC=ZRS(:, :, :, 2, IBL), & + & PRVS=PRS(:, :, :, 1, IBL), PRCS=PRS(:, :, :, 2, IBL), PTH=ZRS(:, :, :, 0, IBL), PTHS=PTHS (:, :, :, IBL), & + & OCOMPUTE_SRC=.TRUE., & + & PSRCS=PSRCS (:, :, :, IBL), PCLDFR=PCLDFR (:, :, :, IBL), PRR=ZRS(:, :, :, 3, IBL), PRI=ZRS(:, :, :, 4, IBL), & + & PRIS=PRS(:, :, :, 4, IBL), PRS=ZRS(:, :, :, 5, IBL), PRG=ZRS(:, :, :, 6, IBL), PHLC_HRC=PHLC_HRC(:, :, :, IBL), & + & PHLC_HCF=PHLC_HCF(:, :, :, IBL), PHLI_HRI=PHLI_HRI(:, :, :, IBL), PHLI_HCF=PHLI_HCF(:, :, :, IBL), & + & TBUDGETS=YLBUDGET, KBUDGETS=NBUDGET_RI, & + & PICE_CLD_WGT=ZICE_CLD_WGT(:, :, IBL) & +#ifdef USE_STACK + & , YDSTACK=YLSTACK & +#endif + & ) + +#ifdef _OPENACC + ENDDO +#endif + + ENDDO + +#ifdef USE_OPENMP +!$OMP END PARALLEL +#endif + +!$acc end parallel loop + + TEC = OMP_GET_WTIME () + +!$acc end data + + TED = OMP_GET_WTIME () + + ZTC = ZTC + (TEC - TSC) + ZTD = ZTD + (TED - TSD) + +ENDDO + +IF (LHOOK) CALL DR_HOOK ('MAIN',1,ZHOOK_HANDLE) + +TE = OMP_GET_WTIME() + +WRITE (*,'(A,F8.2,A)') 'elapsed time : ',TE-TS,' s' +WRITE (*,'(A,F8.4,A)') ' i.e. ',1000.*(TE-TS)/(NPROMA*NGPBLKS)/NTIME,' ms/gp' + +PRINT *, " ZTD = ", ZTD, ZTD / REAL (NPROMA*NGPBLKS*NTIME) +PRINT *, " ZTC = ", ZTC, ZTC / REAL (NPROMA*NGPBLKS*NTIME) + + +IF (LLCHECK .OR. LLSTAT .OR. LLCHECKDIFF) THEN + DO IBL = IBLOCK1, IBLOCK2 + PRINT *, " IBL = ", IBL + CALL DIFF ("PSRCS", PSRCS_OUT (:,:,:,IBL), PSRCS (:,:,:,IBL)) + CALL DIFF ("PCLDFR", PCLDFR_OUT (:,:,:,IBL), PCLDFR (:,:,:,IBL)) + CALL DIFF ("PHLC_HRC", PHLC_HRC_OUT (:,:,:,IBL), PHLC_HRC (:,:,:,IBL)) + CALL DIFF ("PHLC_HCF", PHLC_HCF_OUT (:,:,:,IBL), PHLC_HCF (:,:,:,IBL)) + CALL DIFF ("PHLI_HRI", PHLI_HRI_OUT (:,:,:,IBL), PHLI_HRI (:,:,:,IBL)) + CALL DIFF ("PHLI_HCF", PHLI_HCF_OUT (:,:,:,IBL), PHLI_HCF (:,:,:,IBL)) + ENDDO +ENDIF + +IF (LLCHECKDIFF) THEN + IF (LLDIFF) THEN + PRINT*, "THERE ARE DIFF SOMEWHERE" + ELSE + PRINT*, "THERE IS NO DIFF AT ALL" + ENDIF +ENDIF + +STOP + +CONTAINS + +SUBROUTINE DIFF (CDNAME, PREF, POUT) + +CHARACTER (LEN=*) :: CDNAME +REAL :: PREF (:,:,:) +REAL :: POUT (:,:,:) + +INTEGER :: JLON, JLEV + +PRINT *, CDNAME +IF (LLSTAT) THEN + PRINT *, MINVAL (PREF), MAXVAL (PREF), SUM (PREF) / SIZE (PREF) + PRINT *, MINVAL (POUT), MAXVAL (POUT), SUM (POUT) / SIZE (POUT) +ENDIF + +IF (LLCHECK) THEN + IF (SUM (ABS (POUT) + ABS (PREF)) > 0) THEN + WRITE (*, '(A4)', ADVANCE='NO') "" + DO JLON = 1, NPROMA + WRITE (*, '("|",I12,A12)', ADVANCE='NO') JLON, "" + ENDDO + WRITE (*, '("|")') + DO JLEV = 1, KLEV + WRITE (*, '(I4)', ADVANCE='NO') JLEV + DO JLON = 1, NPROMA + IF (ABS (PREF (JLON, 1, JLEV)) + ABS (POUT (JLON, 1, JLEV)) == 0.) THEN + WRITE (*, '("|",2A12)', ADVANCE='NO') "", "" + ELSE + WRITE (*, '("|",2E12.5)', ADVANCE='NO') PREF (JLON, 1, JLEV), POUT (JLON, 1, JLEV) + ENDIF + ENDDO + WRITE (*, '("|")') + ENDDO + ENDIF +ENDIF + +IF (LLCHECKDIFF) THEN + IF (SUM(ABS(POUT-PREF)) > 0.) THEN + PRINT*, "THERE ARE DIFF" + LLDIFF = .TRUE. + ELSE + PRINT*, "THERE IS NO DIFF" + ENDIF +ENDIF + +END SUBROUTINE + + +END diff --git a/src/testprogs/ice_adjust/stack_mod.F90 b/src/testprogs/ice_adjust/stack_mod.F90 new file mode 100644 index 0000000000000000000000000000000000000000..b02784fb84a2c467b8d521b6a56614f9e4350bda --- /dev/null +++ b/src/testprogs/ice_adjust/stack_mod.F90 @@ -0,0 +1,26 @@ +MODULE STACK_MOD + +IMPLICIT NONE + +TYPE STACK + INTEGER*8 :: L, U +END TYPE + +PRIVATE + +PUBLIC :: STACK, SOF + +CONTAINS + +SUBROUTINE SOF (CDFILE, KLINE) +!$acc routine (SOF) seq + +CHARACTER (LEN=*) :: CDFILE +INTEGER :: KLINE + +PRINT *, 'AT ', CDFILE, ':', KLINE +STOP 1 + +END SUBROUTINE + +END MODULE diff --git a/src/testprogs/ice_adjust/xrd_getoptions.F90 b/src/testprogs/ice_adjust/xrd_getoptions.F90 new file mode 100644 index 0000000000000000000000000000000000000000..0d726c9c040f3903c84e0bc0491be2612a0c315f --- /dev/null +++ b/src/testprogs/ice_adjust/xrd_getoptions.F90 @@ -0,0 +1,828 @@ +MODULE XRD_GETOPTIONS + +!**** *XRD_GETOPTIONS* - Parse command lines options in long form + +! Author. +! ------- +! Philippe Marguinaud *METEO FRANCE* +! Original : 11-09-2012 + +USE PARKIND1, ONLY: JPIM, JPRB, JPLM + +USE XRD_UNIX_ENV, ONLY: XRD_IARGC, XRD_GETARG, & + XRD_BASENAME, XRD_COUNTWORDS, XRD_GETENV, & + XRD_ISALPHA, XRD_ISDIGIT, XRD_EXIT + +IMPLICIT NONE + +INTERFACE GETOPTION + MODULE PROCEDURE GETOPTIONS, GETOPTIONSL, & + GETOPTIONI, GETOPTIONIL, & + GETOPTIONR, GETOPTIONRL, & + GETOPTIONB + +END INTERFACE + +!! @TODO : LIST WITH FIXED SIZE + +PUBLIC :: GETOPTION, INITOPTIONS, CHECKOPTIONS, ADDGROUP + +INTEGER, PARAMETER :: ARGSIZEMAX = 256 + +CHARACTER(LEN=ARGSIZEMAX), POINTER :: MYARGS(:) => NULL() +LOGICAL(KIND=JPLM), POINTER :: CHECK_ARGS(:) => NULL() +LOGICAL(KIND=JPLM) :: LHELP = .FALSE., LSHELL = .FALSE. + +CHARACTER(LEN=1056) :: MESSAGE_OPT = "" + + +TYPE XRD_OPT + CHARACTER(LEN=32) :: KEY, TYPE + CHARACTER(LEN=1024) :: USE + LOGICAL(KIND=JPLM) :: GROUP = .FALSE. +END TYPE + +INTEGER(KIND=JPIM) :: NOPT_SEEN +TYPE(XRD_OPT), POINTER :: OPT_SEEN(:) => NULL() + +PRIVATE + +CONTAINS + +SUBROUTINE ADDGROUP( USE ) +CHARACTER(LEN=*), INTENT(IN) :: USE + +CALL INIT_OPT_SEEN() +NOPT_SEEN = NOPT_SEEN + 1 +CALL GROW_OPT_SEEN() + +OPT_SEEN(NOPT_SEEN)%GROUP = .TRUE. +OPT_SEEN(NOPT_SEEN)%USE = USE + + +END SUBROUTINE + +CHARACTER(LEN=ARGSIZEMAX) FUNCTION GET_ENV_OPT( KEY ) +CHARACTER(LEN=*), INTENT(IN) :: KEY +CHARACTER(LEN=ARGSIZEMAX) :: KEY_ENV, VAL_ENV +INTEGER(KIND=JPIM) :: I, N +CHARACTER :: C + +KEY_ENV = KEY(3:) + +N = LEN(TRIM(KEY_ENV)) +DO I = 1, N + C = KEY_ENV(I:I) + IF((.NOT.XRD_ISALPHA(C)) .AND. & + (.NOT.XRD_ISDIGIT(C)) .AND. & + (C .NE. '_' )) THEN + KEY_ENV(I:I) = '_' + ENDIF +ENDDO + +VAL_ENV = "" +CALL XRD_GETENV( 'XRD_OPT_'//TRIM(KEY_ENV), VAL_ENV ) + +!PRINT *, " KEY = ", TRIM(KEY_ENV), " VAL = ", TRIM(VAL_ENV) + +GET_ENV_OPT = VAL_ENV + +END FUNCTION + +SUBROUTINE MYGETARG( I, S ) + INTEGER(KIND=JPIM), INTENT(IN) :: I + CHARACTER(LEN=*), INTENT(OUT) :: S +! + IF( I .LE. UBOUND( MYARGS, 1 ) ) THEN + S = MYARGS(I) + ELSE + S = "" + ENDIF +END SUBROUTINE + +INTEGER FUNCTION MYIARGC() + INTEGER :: N + N = UBOUND( MYARGS, 1 ) + MYIARGC = N +END FUNCTION + +SUBROUTINE ADDOPT_SHELL( KEY, TYPE, MND, USE ) + CHARACTER*(*), INTENT(IN) :: KEY, TYPE, USE + LOGICAL(KIND=JPLM), INTENT(IN) :: MND + OPTIONAL :: USE, MND +! + CHARACTER(LEN=ARGSIZEMAX) :: STR + INTEGER :: NN, N, N1, I1, I2, K + CHARACTER(LEN=ARGSIZEMAX), POINTER :: MYARGS1(:) + + MYARGS1 => NULL() + + IF( PRESENT( USE ) ) WRITE( *, '("> ",A)' ) TRIM(USE) + IF( PRESENT( MND ) ) THEN + IF( MND ) WRITE( *, * ) "[MANDATORY]" + ENDIF + WRITE( *, * ) "* OPTION: [", TYPE, "]", " ", TRIM(KEY) + READ( *, '(A)' ) STR + +! PRINT *, "STR = ",TRIM(STR) + IF( TRIM(STR) .NE. "" ) THEN + IF( TYPE .EQ. 'FLAG' ) THEN + NN = 0 + ELSE + NN = XRD_COUNTWORDS( STR ) + ENDIF + N = UBOUND( MYARGS, 1 ) + N1 = N + NN + 1 + +! +! REALLOC MYARGS +! + ALLOCATE( MYARGS1(0:N1) ) + MYARGS1(0:N) = MYARGS(0:N) + DEALLOCATE( MYARGS ) + MYARGS => MYARGS1 + MYARGS(N+1) = KEY + +! +! PARSE ARGUMENT LIST +! + IF( TYPE .NE. 'FLAG' ) THEN + K = 1 + I1 = 1 + LOOP_I1 : DO + DO + IF( I1 .GT. LEN(STR)) EXIT LOOP_I1 + IF( STR(I1:I1) .NE. ' ' ) EXIT + I1 = I1+1 + ENDDO + I2 = I1+1 + DO + IF( I2 .GT. LEN(STR)) EXIT + IF( STR(I2:I2) .EQ. ' ' ) EXIT + I2 = I2+1 + ENDDO +!PRINT *, I1, I2 + MYARGS(N+1+K) = STR(I1:I2-1) +!PRINT *, K, TRIM(MYARGS(N+1+K)) + K = K+1 + I1 = I2+1 + ENDDO LOOP_I1 + ENDIF + ENDIF + +END SUBROUTINE + +SUBROUTINE INIT_OPT_SEEN() + + IF( .NOT. ASSOCIATED( OPT_SEEN ) ) THEN + NOPT_SEEN = 0 + ALLOCATE( OPT_SEEN( 32 ) ) + ENDIF + +END SUBROUTINE + +SUBROUTINE GROW_OPT_SEEN() + INTEGER(KIND=JPIM) :: N + TYPE(XRD_OPT), POINTER :: OPT_SEEN1(:) + + N = SIZE( OPT_SEEN ) + IF( NOPT_SEEN .GE. N ) THEN ! REALLOC DATA + OPT_SEEN1 => OPT_SEEN + ALLOCATE( OPT_SEEN( 2 * N ) ) + OPT_SEEN(1:NOPT_SEEN) = OPT_SEEN1(1:NOPT_SEEN) + DEALLOCATE( OPT_SEEN1 ) + ENDIF + +END SUBROUTINE + +SUBROUTINE ADDOPT( KEY, TYPE, USE ) + CHARACTER*(*), INTENT(IN) :: KEY, TYPE, USE + OPTIONAL :: USE + + CALL INIT_OPT_SEEN() + + NOPT_SEEN = NOPT_SEEN + 1 + + CALL GROW_OPT_SEEN() + + OPT_SEEN(NOPT_SEEN)%KEY = KEY + OPT_SEEN(NOPT_SEEN)%TYPE = TYPE + + IF( PRESENT( USE ) ) THEN + OPT_SEEN(NOPT_SEEN)%USE = USE + ELSE + OPT_SEEN(NOPT_SEEN)%USE = '' + ENDIF + +END SUBROUTINE + +SUBROUTINE INITOPTIONS( CDMESSAGE, KOPTMIN, KOPTMAX, CDARGS ) + CHARACTER(LEN=*), OPTIONAL, INTENT (IN) :: CDMESSAGE + INTEGER (KIND=JPIM), OPTIONAL, INTENT (IN) :: KOPTMIN, KOPTMAX + CHARACTER (LEN=*), OPTIONAL, INTENT (IN) :: CDARGS (0:) + INTEGER(KIND=JPIM) :: N, I + INTEGER(KIND=JPIM) :: IOPTMIN, IOPTMAX + CHARACTER*32 :: STR + + IF (PRESENT (CDARGS)) THEN + N = UBOUND (CDARGS, 1) + ELSE + N = XRD_IARGC() + ENDIF + + IOPTMIN = 0 + IOPTMAX = N + IF (PRESENT (KOPTMIN)) IOPTMIN = KOPTMIN + IF (PRESENT (KOPTMAX)) IOPTMAX = KOPTMAX + + N = IOPTMAX-IOPTMIN + + ALLOCATE( MYARGS(0:N) ) + DO I = 0, N + IF (PRESENT (CDARGS)) THEN + MYARGS(I) = CDARGS (IOPTMIN+I) + ELSE + CALL XRD_GETARG( IOPTMIN+I, MYARGS(I) ) + ENDIF + ENDDO + + IF( PRESENT( CDMESSAGE ) ) THEN + MESSAGE_OPT = CDMESSAGE + ELSE + MESSAGE_OPT = "" + ENDIF + + IF( N .EQ. 1 ) THEN + CALL MYGETARG( 1_JPIM, STR ) + IF( TRIM( STR ) .EQ. '--help' ) THEN + LHELP = .TRUE. + RETURN + ELSE IF( TRIM( STR ) .EQ. '--shell' ) THEN + LSHELL = .TRUE. + RETURN + ENDIF + ENDIF + + LHELP = .FALSE. + ALLOCATE( CHECK_ARGS( N ) ) + CHECK_ARGS = .FALSE. + +END SUBROUTINE + + + +SUBROUTINE CHECKOPTIONS() + INTEGER(KIND=JPIM) :: I, N, IS, NS, KS + CHARACTER(LEN=ARGSIZEMAX) :: OPT, PROG + LOGICAL(KIND=JPLM) :: PB + CHARACTER(LEN=10) :: FMT + CHARACTER(LEN=110) :: BUF + + CALL MYGETARG( 0_JPIM, PROG ) + + IF( LHELP ) THEN + PRINT *, "PROGRAM: ", TRIM(XRD_BASENAME( PROG )) + IF( TRIM(MESSAGE_OPT) .NE. "" ) THEN + NS = LEN(MESSAGE_OPT) + DO IS = 1, NS / 96 + KS = LEN( TRIM(MESSAGE_OPT(1+(IS-1)*96:IS*96)) ) + IF( KS .GT. 0 ) THEN + IF( IS .EQ. 1 ) THEN + WRITE( *, '(" ")', ADVANCE = 'NO' ) + ELSE + WRITE( *, '(" > ")', ADVANCE = 'NO' ) + ENDIF + WRITE( FMT, '("(A",I2,")")' ) KS + WRITE( *, FMT ) TRIM(MESSAGE_OPT(1+(IS-1)*96:IS*96)) + ENDIF + ENDDO + ENDIF + DO I = 1, NOPT_SEEN + + IF(OPT_SEEN(I)%GROUP) THEN + WRITE( *, * ) + IF( TRIM(OPT_SEEN(I)%USE) .NE. "" ) & + WRITE( *, * ) '* '//TRIM(OPT_SEEN(I)%USE) + CYCLE + ENDIF + + BUF = "" + + WRITE( BUF, '(A32," = ",A15)' ) & + TRIM(OPT_SEEN(I)%KEY), & + TRIM(OPT_SEEN(I)%TYPE) + + IF( TRIM(OPT_SEEN(I)%USE) .NE. '' ) THEN + NS = LEN( OPT_SEEN(I)%USE) + DO IS = 1, NS / 48 + KS = LEN(TRIM(OPT_SEEN(I)%USE(1+(IS-1)*48:IS*48))) + IF( KS .GT. 0 ) THEN + IF( IS .EQ. 1 ) THEN + BUF = TRIM(BUF)//" : "//TRIM(OPT_SEEN(I)%USE(1+(IS-1)*48:IS*48)) + ELSE +! 000000000011111111112222222222333333333344444444445555555555 +! 012345678901234567890123456789012345678901234567890123456789 + BUF = " > "& + //TRIM(OPT_SEEN(I)%USE(1+(IS-1)*48:IS*48)) + ENDIF + WRITE( *, * ) BUF + ENDIF + ENDDO + ELSE + WRITE( *, * ) BUF + WRITE( *, * ) + ENDIF + + ENDDO + STOP + ELSE IF( ASSOCIATED( CHECK_ARGS ) ) THEN + N = SIZE( CHECK_ARGS ) + PB = .FALSE. + DO I = 1, N + IF( .NOT. CHECK_ARGS(I) ) THEN + CALL MYGETARG( I, OPT ) + IF( OPT(1:2) .EQ. '--' ) THEN + PRINT *, 'INVALID OPTION: ', TRIM(OPT) + PB = .TRUE. + CHECK_ARGS(I) = .TRUE. + ENDIF + ENDIF + ENDDO + + DO I = 1, N + IF( .NOT. CHECK_ARGS(I) ) THEN + CALL MYGETARG( I, OPT ) + PRINT *, 'GARBAGE IN OPTIONS:`', TRIM(OPT), "'" + PB = .TRUE. + EXIT + ENDIF + ENDDO + + IF( PB ) CALL XRD_EXIT(1_JPIM) + + DEALLOCATE( CHECK_ARGS ) + ELSE IF( LSHELL ) THEN + OPEN( 77, FILE = TRIM(PROG)//'.sh', FORM = 'FORMATTED' ) + WRITE( 77, '("#!/bin/sh")' ) + WRITE( 77, * ) + WRITE( 77, '(A)', ADVANCE = 'NO' ) TRIM(PROG) + N = UBOUND( MYARGS, 1 ) + DO I = 1, N + IF( MYARGS(I) .EQ. '--shell' ) CYCLE + IF( MYARGS(I)(1:2) .EQ. '--' ) THEN + WRITE( 77, '(" \")' ) + WRITE( 77, '(" ")', ADVANCE = 'NO' ) + ENDIF + WRITE( 77, '(" ",A)', ADVANCE = 'NO' ) TRIM(MYARGS(I)) + ENDDO + WRITE( 77, * ) + CLOSE(77) + ENDIF + + + + IF( ASSOCIATED( OPT_SEEN ) ) DEALLOCATE( OPT_SEEN ) + IF( ASSOCIATED( MYARGS ) ) DEALLOCATE( MYARGS ) +END SUBROUTINE + + +SUBROUTINE CHECK_MND( KEY, MND, USE ) + CHARACTER(LEN=*), INTENT(IN) :: KEY + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE + LOGICAL(KIND=JPLM), OPTIONAL, INTENT(IN) :: MND +! + CHARACTER(LEN=ARGSIZEMAX) :: PROG + + IF( PRESENT( MND ) ) THEN + IF( MND ) THEN + CALL MYGETARG( 0_JPIM, PROG ) + WRITE( *, '("PROGRAM: ",(A))' ) TRIM( PROG ) + WRITE( *, '("ERROR: OPTION `",(A),"'' IS MANDATORY")' ) TRIM( KEY ) + IF( PRESENT( USE ) ) WRITE( *, '(" ",(A)," : ",(A))' ) TRIM( KEY ), TRIM( USE ) + CALL XRD_EXIT(1_JPIM) + ENDIF + ENDIF + +END SUBROUTINE + +SUBROUTINE FINDARGINDEX( KEY, I, N ) + CHARACTER(LEN=*), INTENT(IN) :: KEY + INTEGER(KIND=JPIM), INTENT(OUT) :: I, N + CHARACTER(LEN=ARGSIZEMAX) :: ARG + + N = MYIARGC() + DO I = 1, N + CALL MYGETARG( I, ARG ) + IF( TRIM( ARG ) .EQ. TRIM( KEY ) ) RETURN + ENDDO + I = -1_JPIM +END SUBROUTINE + +SUBROUTINE FINDNEXTARGINDEX( I, J ) + INTEGER(KIND=JPIM), INTENT(IN) :: I + INTEGER(KIND=JPIM), INTENT(OUT) :: J +! + CHARACTER(LEN=ARGSIZEMAX) :: ARG + INTEGER(KIND=JPIM) :: N + + N = MYIARGC() + DO J = I+1, N + CALL MYGETARG( J, ARG ) + IF( ARG(1:2) .EQ. '--' ) EXIT + ENDDO + +END SUBROUTINE + +SUBROUTINE GETOPTIONS( KEY, VAL, MND, USE ) +! + CHARACTER(LEN=*), INTENT(IN) :: KEY + CHARACTER(LEN=*), INTENT(INOUT) :: VAL + LOGICAL(KIND=JPLM), INTENT(IN), OPTIONAL :: MND + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: USE +! + INTEGER(KIND=JPIM) :: I, N + CHARACTER(LEN=ARGSIZEMAX) :: ARG + LOGICAL(KIND=JPLM) :: LSHELL1 + LOGICAL(KIND=JPLM) :: FOUND + + LSHELL1 = LSHELL + + IF( LHELP ) THEN + CALL ADDOPT( KEY, 'STRING', USE ) + RETURN + ELSE IF( LSHELL ) THEN + LSHELL = .FALSE. + CALL ADDOPT_SHELL( KEY, 'STRING', MND, USE ) + ENDIF + + CALL FINDARGINDEX( KEY, I, N ) + + FOUND = ( 0 .LT. I ) .AND. ( I .LT. N ) + + IF( FOUND ) THEN + IF( ASSOCIATED( CHECK_ARGS ) ) THEN + CHECK_ARGS(I) = .TRUE. + CHECK_ARGS(I+1) = .TRUE. + ENDIF + CALL MYGETARG( I+1_JPIM, VAL ) + ELSE + ARG = GET_ENV_OPT( KEY ) + FOUND = ARG .NE. "" + IF( FOUND ) VAL = ARG + ENDIF + + IF( .NOT. FOUND ) & + CALL CHECK_MND( KEY, MND, USE ) + + LSHELL = LSHELL1 + +END SUBROUTINE + +SUBROUTINE GETOPTIONI( KEY, VAL, MND, USE ) +! + CHARACTER(LEN=*), INTENT(IN) :: KEY + INTEGER(KIND=JPIM), INTENT(INOUT) :: VAL + LOGICAL(KIND=JPLM), OPTIONAL, INTENT(IN) :: MND + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE +! + CHARACTER(LEN=ARGSIZEMAX) :: SVAL + INTEGER :: ERR + LOGICAL(KIND=JPLM) :: LSHELL1 + + LSHELL1 = LSHELL + + IF( LHELP ) THEN + CALL ADDOPT( KEY, 'INTEGER', USE ) + RETURN + ELSE IF( LSHELL ) THEN + LSHELL = .FALSE. + CALL ADDOPT_SHELL( KEY, 'INTEGER', MND, USE ) + ENDIF + + SVAL = "" + CALL GETOPTIONS( KEY, SVAL, MND, USE ) + IF( TRIM( SVAL ) .NE. "" ) THEN + READ( SVAL, *, IOSTAT = ERR ) VAL + IF( ERR .NE. 0 ) THEN + PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) + CALL XRD_EXIT(1_JPIM) + ENDIF + ENDIF + + LSHELL = LSHELL1 + +END SUBROUTINE + +SUBROUTINE GETOPTIONR( KEY, VAL, MND, USE ) +! + CHARACTER(LEN=*), INTENT(IN) :: KEY + REAL(KIND=JPRB), INTENT(INOUT) :: VAL + LOGICAL(KIND=JPLM), OPTIONAL, INTENT(IN) :: MND + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE +! + CHARACTER(LEN=ARGSIZEMAX) :: SVAL + INTEGER :: ERR + LOGICAL(KIND=JPLM) :: LSHELL1 + + LSHELL1 = LSHELL + + IF( LHELP ) THEN + CALL ADDOPT( KEY, 'REAL', USE ) + RETURN + ELSE IF( LSHELL ) THEN + LSHELL = .FALSE. + CALL ADDOPT_SHELL( KEY, 'REAL', MND, USE ) + ENDIF + + SVAL = "" + CALL GETOPTIONS( KEY, SVAL, MND, USE ) + IF( TRIM( SVAL ) .NE. "" ) THEN + READ( SVAL, *, IOSTAT = ERR ) VAL + IF( ERR .NE. 0 ) THEN + PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) + CALL XRD_EXIT(1_JPIM) + ENDIF + ENDIF + + LSHELL = LSHELL1 + +END SUBROUTINE + +SUBROUTINE READASLFROMSTRING( VAL, SVAL ) + CHARACTER(LEN=*), INTENT(OUT) :: VAL(:) + CHARACTER(LEN=*), INTENT(IN) :: SVAL +! + INTEGER(KIND=JPIM) :: I, J, K, N + + N = LEN( SVAL ) + + I = 1 + K = 1 + DO1 : DO + DO + IF( I .GT. N ) EXIT DO1 + IF( SVAL(I:I) .NE. ' ' ) EXIT + I = I + 1 + ENDDO + J = I + DO + IF( J .GT. N ) EXIT + IF( SVAL(J:J) .EQ. ' ' ) EXIT + J = J + 1 + ENDDO + + VAL(K) = SVAL(I:J-1) + I = J + K = K + 1 + ENDDO DO1 + + +END SUBROUTINE + +SUBROUTINE READSLFROMSTRING( VAL, SVAL ) + CHARACTER(LEN=*), POINTER :: VAL(:) + CHARACTER(LEN=*), INTENT(IN) :: SVAL +! + INTEGER(KIND=JPIM) :: N + + N = XRD_COUNTWORDS( SVAL ) + ALLOCATE( VAL( N ) ) + + CALL READASLFROMSTRING( VAL, SVAL ) + +END SUBROUTINE + +SUBROUTINE READSLFROMFILE( VAL, SVAL ) + CHARACTER(LEN=*), POINTER :: VAL(:) + CHARACTER(LEN=*), INTENT(IN) :: SVAL +! + INTEGER(KIND=JPIM) :: K, N + INTEGER(KIND=JPIM) :: IOERR + CHARACTER(LEN=4096) :: BUFFER + + OPEN( 77, FILE = TRIM(SVAL), FORM = 'FORMATTED', STATUS = 'OLD', IOSTAT = IOERR ) + IF( IOERR .NE. 0 ) THEN + PRINT '( "COULD NOT OPEN ",A, " FOR READING")', TRIM(SVAL) + CALL XRD_EXIT(1_JPIM) + ENDIF + N = 0_JPIM + DO + READ( 77, '(A)', END = 500 ) BUFFER + N = N + XRD_COUNTWORDS( BUFFER ) + ENDDO + + 500 CONTINUE + + REWIND( 77 ) + + ALLOCATE( VAL( N ) ) + + K = 1 + DO + READ( 77, '(A)', END = 600 ) BUFFER + N = XRD_COUNTWORDS( BUFFER ) + CALL READASLFROMSTRING( VAL(K:K+N-1), BUFFER ) + K = K + N + ENDDO + + 600 CONTINUE + + + CLOSE( 77 ) + +END SUBROUTINE + +SUBROUTINE GETOPTIONSL( KEY, VAL, MND, USE ) +! + CHARACTER(LEN=*), INTENT(IN) :: KEY + CHARACTER(LEN=*), POINTER :: VAL(:) + LOGICAL(KIND=JPLM), OPTIONAL, INTENT(IN) :: MND + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE +! + INTEGER(KIND=JPIM) :: I, J, K, N + CHARACTER(LEN=ARGSIZEMAX) :: ARG + CHARACTER(LEN=ARGSIZEMAX) :: SVAL + LOGICAL(KIND=JPLM) :: LSHELL1 + LOGICAL(KIND=JPLM) :: FOUND + + LSHELL1 = LSHELL + + IF( LHELP ) THEN + CALL ADDOPT( KEY, 'STRING-LIST', USE ) + RETURN + ELSE IF( LSHELL ) THEN + LSHELL = .FALSE. + CALL ADDOPT_SHELL( KEY, 'STRING-LIST', MND, USE ) + ENDIF + + CALL FINDARGINDEX( KEY, I, N ) + + FOUND = I >= 0 + + IF( FOUND ) THEN + + CALL FINDNEXTARGINDEX( I, J ) + + ALLOCATE( VAL( J - I - 1 ) ) + + IF( ASSOCIATED( CHECK_ARGS ) ) & + CHECK_ARGS(I) = .TRUE. + + DO K = I+1, J-1 + IF( ASSOCIATED( CHECK_ARGS ) ) & + CHECK_ARGS(K) = .TRUE. + CALL MYGETARG( K, ARG ) + IF ((I+1.EQ.J-1) .AND. (ARG(1:7).EQ.'file://')) THEN + DEALLOCATE (VAL) + ARG = ARG(8:) + CALL READSLFROMFILE( VAL, ARG ) + ELSE + VAL(K-I) = ARG + ENDIF + ENDDO + + ENDIF + + IF(.NOT. FOUND) THEN + SVAL = GET_ENV_OPT( KEY ) + FOUND = SVAL .NE. "" + IF( FOUND ) & + CALL READSLFROMSTRING( VAL, SVAL ) + ENDIF + + IF( .NOT. FOUND ) & + CALL CHECK_MND( KEY, MND, USE ) + + LSHELL = LSHELL1 + +END SUBROUTINE + +SUBROUTINE GETOPTIONIL( KEY, VAL, MND, USE ) +! + CHARACTER(LEN=*), INTENT(IN) :: KEY + INTEGER(KIND=JPIM), POINTER :: VAL(:) + LOGICAL(KIND=JPLM), OPTIONAL, INTENT(IN) :: MND + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE +! + CHARACTER(LEN=ARGSIZEMAX), POINTER :: SVAL(:) + INTEGER(KIND=JPIM) :: I, N + INTEGER :: ERR + LOGICAL(KIND=JPLM) :: LSHELL1 + + NULLIFY (SVAL) + + LSHELL1 = LSHELL + + IF( LHELP ) THEN + CALL ADDOPT( KEY, 'INTEGER-LIST', USE ) + RETURN + ELSE IF( LSHELL ) THEN + LSHELL = .FALSE. + CALL ADDOPT_SHELL( KEY, 'INTEGER-LIST', MND, USE ) + ENDIF + + CALL GETOPTIONSL( KEY, SVAL, MND, USE ) + + IF( .NOT. ASSOCIATED( SVAL ) ) GOTO 999 + + N = SIZE( SVAL ) + ALLOCATE( VAL( N ) ) + DO I = 1, N + READ( SVAL( I ), *, IOSTAT = ERR ) VAL( I ) + IF( ERR .NE. 0 ) THEN + PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) + CALL XRD_EXIT(1_JPIM) + ENDIF + ENDDO + + DEALLOCATE( SVAL ) + +999 CONTINUE + LSHELL = LSHELL1 + +END SUBROUTINE + +SUBROUTINE GETOPTIONRL( KEY, VAL, MND, USE ) +! + CHARACTER(LEN=*), INTENT(IN) :: KEY + REAL(KIND=JPRB), POINTER :: VAL(:) + LOGICAL(KIND=JPLM), OPTIONAL, INTENT(IN) :: MND + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE +! + CHARACTER(LEN=ARGSIZEMAX), POINTER :: SVAL(:) + INTEGER(KIND=JPIM) :: I, N + INTEGER :: ERR + LOGICAL(KIND=JPLM) :: LSHELL1 + + NULLIFY (SVAL) + + LSHELL1 = LSHELL + + IF( LHELP ) THEN + CALL ADDOPT( KEY, 'REAL-LIST', USE ) + RETURN + ELSE IF( LSHELL ) THEN + LSHELL = .FALSE. + CALL ADDOPT_SHELL( KEY, 'REAL-LIST', MND, USE ) + ENDIF + + CALL GETOPTIONSL( KEY, SVAL, MND, USE ) + + IF( .NOT. ASSOCIATED( SVAL ) ) GOTO 999 + + N = SIZE( SVAL ) + ALLOCATE( VAL( N ) ) + DO I = 1, N + READ( SVAL( I ), *, IOSTAT = ERR ) VAL( I ) + IF( ERR .NE. 0 ) THEN + PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) + CALL XRD_EXIT(1_JPIM) + ENDIF + ENDDO + + DEALLOCATE( SVAL ) + +999 CONTINUE + LSHELL = LSHELL1 + +END SUBROUTINE + +SUBROUTINE GETOPTIONB( KEY, VAL, USE ) +! + CHARACTER(LEN=*), INTENT(IN) :: KEY + LOGICAL(KIND=JPLM), INTENT(INOUT) :: VAL + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE +! + LOGICAL(KIND=JPLM) :: LSHELL1 + LOGICAL(KIND=JPLM) :: FOUND + CHARACTER(LEN=ARGSIZEMAX) :: SVAL + INTEGER(KIND=JPIM) :: I, N + + LSHELL1 = LSHELL + + VAL = .FALSE. + + IF( LHELP ) THEN + CALL ADDOPT( KEY, 'FLAG', USE ) + RETURN + ELSE IF( LSHELL ) THEN + LSHELL = .FALSE. + CALL ADDOPT_SHELL( KEY, 'FLAG', .FALSE._JPLM, USE ) + ENDIF + + CALL FINDARGINDEX( KEY, I, N ) + FOUND = I > 0 + IF( FOUND .AND. ASSOCIATED( CHECK_ARGS ) ) THEN + CHECK_ARGS(I) = .TRUE. + VAL = .TRUE. + ELSE + SVAL = GET_ENV_OPT( KEY ) + IF( SVAL .NE. "" ) & + READ( SVAL, * ) VAL + ENDIF + + LSHELL = LSHELL1 + +END SUBROUTINE + +END MODULE diff --git a/src/testprogs/ice_adjust/xrd_unix_env.F90 b/src/testprogs/ice_adjust/xrd_unix_env.F90 new file mode 100644 index 0000000000000000000000000000000000000000..c689c6255ffed05f25c2f988961d679f3d186476 --- /dev/null +++ b/src/testprogs/ice_adjust/xrd_unix_env.F90 @@ -0,0 +1,181 @@ +MODULE XRD_UNIX_ENV + +!**** *XRD_UNIX_ENV* - + +! Author. +! ------- +! Philippe Marguinaud *METEO FRANCE* +! Original : 11-09-2012 + +USE PARKIND1, ONLY : JPIM, JPRB, JPLM +IMPLICIT NONE + +CONTAINS + +SUBROUTINE XRD_GETENV( KEY, VAL ) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: KEY + CHARACTER(LEN=*), INTENT(OUT) :: VAL + + CALL GET_ENVIRONMENT_VARIABLE( KEY, VAL ) +END SUBROUTINE + + +FUNCTION XRD_IARGC() + IMPLICIT NONE + INTEGER(KIND=JPIM) :: XRD_IARGC + XRD_IARGC = COMMAND_ARGUMENT_COUNT() +END FUNCTION + +SUBROUTINE XRD_GETARG( KEY, VAL ) + IMPLICIT NONE + INTEGER(KIND=JPIM), INTENT(IN) :: KEY + CHARACTER(LEN=*), INTENT(OUT) :: VAL + CALL GETARG( INT(KEY,SELECTED_INT_KIND(9)), VAL ) +END SUBROUTINE + +SUBROUTINE XRD_EXIT( STATUS ) + IMPLICIT NONE + INTEGER(KIND=JPIM), INTENT(IN) :: STATUS + CALL EXIT( INT(STATUS,SELECTED_INT_KIND(9)) ) +END SUBROUTINE + +SUBROUTINE XRD_MKDIR( PATH ) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: PATH + CALL SYSTEM( "mkdir -p "//TRIM(PATH)) +END SUBROUTINE + +CHARACTER*256 FUNCTION XRD_DIRNAME( PATH ) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: PATH + + INTEGER(KIND=JPIM) :: I + XRD_DIRNAME = "" + I = LEN( TRIM( PATH ) ) - 1 + DO + IF( I .LE. 0 ) RETURN + IF( PATH(I:I) .EQ. '/' ) EXIT + I = I - 1 + ENDDO + XRD_DIRNAME = PATH(1:I) +END FUNCTION + +FUNCTION XRD_BASENAME( PATH ) + IMPLICIT NONE + CHARACTER*256 :: XRD_BASENAME + CHARACTER(LEN=*), INTENT(IN) :: PATH + + INTEGER(KIND=JPIM) :: I + XRD_BASENAME = "" + I = LEN( TRIM( PATH ) ) - 1 + DO + IF( I .LE. 0 ) THEN + I = 0 + EXIT + ENDIF + IF( PATH(I:I) .EQ. '/' ) EXIT + I = I - 1 + ENDDO + XRD_BASENAME = PATH(I+1:) +END FUNCTION + +ELEMENTAL SUBROUTINE XRD_LOWER_CASE(OUS,INS) +IMPLICIT NONE +! CONVERT A WORD TO LOWER CASE +CHARACTER (LEN=*) , INTENT(OUT) :: OUS +CHARACTER (LEN=*) , INTENT(IN) :: INS +INTEGER :: I,IC,NLEN +NLEN = LEN(INS) +OUS = '' +DO I=1,NLEN + IC = ICHAR(INS(I:I)) + IF (IC >= 65 .AND. IC < 90) THEN + OUS(I:I) = CHAR(IC+32) + ELSE + OUS(I:I) = INS(I:I) + ENDIF +END DO +END SUBROUTINE XRD_LOWER_CASE + +FUNCTION XRD_ISALPHA(C) +IMPLICIT NONE +LOGICAL(KIND=JPLM) :: XRD_ISALPHA +CHARACTER, INTENT(IN) :: C + +XRD_ISALPHA = ((C.GE.'A').AND.(C.LE.'Z'))& + .OR.((C.GE.'a').AND.(C.LE.'z')) + +END FUNCTION + +FUNCTION XRD_ISDIGIT(C) +IMPLICIT NONE +LOGICAL(KIND=JPLM) :: XRD_ISDIGIT +CHARACTER, INTENT(IN) :: C + +XRD_ISDIGIT = (C.GE.'0').AND.(C.LE.'9') + +END FUNCTION + +SUBROUTINE XRD_DATE_AND_TIME( VL ) +IMPLICIT NONE +INTEGER(KIND=JPIM), INTENT(OUT) :: VL(8) +! +INTEGER :: VLX(8) + + CALL DATE_AND_TIME( VALUES = VLX ) + + VL = VLX +END SUBROUTINE + +SUBROUTINE XRD_CPU_TIME( T ) + IMPLICIT NONE + REAL,INTENT(OUT) :: T + CALL CPU_TIME( T ) +END SUBROUTINE + +SUBROUTINE XRD_COUNTLINES( NLINES, F, ERR ) +IMPLICIT NONE +INTEGER(KIND=JPIM), INTENT(OUT) :: NLINES +CHARACTER*(*), INTENT(IN) :: F +INTEGER(KIND=JPIM), INTENT(OUT) :: ERR +CHARACTER*32 :: STR + +NLINES = 0 +OPEN( 77, FILE = F, ERR = 888 ) + +DO + READ( 77, *, ERR = 888, END = 777 ) STR + NLINES = NLINES + 1 +ENDDO + +777 CONTINUE + +CLOSE( 77 ) + +RETURN +888 CONTINUE + ERR = 1 +END SUBROUTINE + +FUNCTION XRD_COUNTWORDS( S ) + IMPLICIT NONE + INTEGER(KIND=JPIM) :: XRD_COUNTWORDS + CHARACTER(LEN=*), INTENT(IN) :: S + INTEGER(KIND=JPIM) :: N, I, L + LOGICAL(KIND=JPLM) :: IN + N = 0_JPIM + IN = .FALSE. + L = LEN( TRIM( S ) ) + DO I = 1, L + IF( S(I:I) .EQ. ' ' ) THEN + IN = .FALSE. + ELSE IF( .NOT. IN ) THEN + N = N + 1 + IN = .TRUE. + ENDIF + ENDDO + XRD_COUNTWORDS = N +END FUNCTION + +END MODULE