From fa3c77696f10380d5723ade39e4a764281c9f666 Mon Sep 17 00:00:00 2001 From: MARY Alexandre Date: Tue, 11 Oct 2022 13:44:57 +0000 Subject: [PATCH 01/12] equivalent to ectrans in CY48T3_mrg48R1.02:contrib/ --- src/trans/algor/fft992.F90 | 53 +++ src/trans/external/gath_spec.F90 | 19 +- src/trans/external/setup_trans0.F90 | 12 +- src/trans/include/ectrans/setup_trans0.h | 5 +- src/trans/internal/dist_spec_control_mod.F90 | 11 +- src/trans/internal/ftdir_ctl_mod.F90 | 23 +- src/trans/internal/ftdir_ctlad_mod.F90 | 22 +- src/trans/internal/ftdir_mod.F90 | 6 +- src/trans/internal/ftinv_ctl_mod.F90 | 31 +- src/trans/internal/ftinv_ctlad_mod.F90 | 21 +- src/trans/internal/gath_spec_control_mod.F90 | 374 +++++++++++-------- src/trans/internal/gpnorm_trans_ctl_mod.F90 | 2 + src/trans/internal/tpm_gen.F90 | 5 + src/trans/internal/trgtol_mod.F90 | 194 ++++++++-- src/trans/internal/trltog_mod.F90 | 205 ++++++++-- 15 files changed, 712 insertions(+), 271 deletions(-) diff --git a/src/trans/algor/fft992.F90 b/src/trans/algor/fft992.F90 index efc9afa3a..b8f172dfd 100644 --- a/src/trans/algor/fft992.F90 +++ b/src/trans/algor/fft992.F90 @@ -479,6 +479,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 210 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) C(JB+J)=A(IA+I)-A(IB+I) @@ -506,6 +507,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 230 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) D(JA+J)=B(IA+I)-B(IB+I) @@ -530,6 +532,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 270 IJK=1,ILOT C(JA+J)=A(IA+I) C(JB+J)=-B(IA+I) @@ -546,6 +549,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 294 L=1,ILA I=IBASE !OCL NOVREC +!NEC$ ivdep DO 292 IJK=1,ILOT T1=2.0*(A(IA+I)-A(IB+I)) A(IA+I)=2.0_JPRB*(A(IA+I)+A(IB+I)) @@ -560,6 +564,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 296 IJK=1,ILOT C(JA+J)=2.0_JPRB*(A(IA+I)+A(IB+I)) C(JB+J)=2.0_JPRB*(A(IA+I)-A(IB+I)) @@ -591,6 +596,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 310 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) C(JB+J)=(A(IA+I)-0.5_JPRB*A(IB+I))-(SIN60*(B(IB+I))) @@ -622,6 +628,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 330 IJK=1,ILOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) D(JA+J)=B(IA+I)+(B(IB+I)-B(IC+I)) @@ -665,6 +672,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 370 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) C(JB+J)=(0.5_JPRB*A(IA+I)-A(IB+I))-(SIN60*B(IA+I)) @@ -683,6 +691,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 394 L=1,ILA I=IBASE !OCL NOVREC +!NEC$ ivdep DO 392 IJK=1,ILOT T1=(2.0_JPRB*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I)) T2=(2.0_JPRB*A(IA+I)-A(IB+I))+(SSIN60*B(IB+I)) @@ -699,6 +708,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 396 IJK=1,ILOT C(JA+J)=2.0_JPRB*(A(IA+I)+A(IB+I)) C(JB+J)=(2.0_JPRB*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I)) @@ -733,6 +743,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 410 IJK=1,ILOT C(JA+J)=(A(IA+I)+A(IC+I))+A(IB+I) C(JB+J)=(A(IA+I)-A(IC+I))-B(IB+I) @@ -769,6 +780,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 430 IJK=1,ILOT C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) D(JA+J)=(B(IA+I)-B(IC+I))+(B(IB+I)-B(ID+I)) @@ -812,6 +824,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 470 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) C(JB+J)=SIN45*((A(IA+I)-A(IB+I))-(B(IA+I)+B(IB+I))) @@ -830,6 +843,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 494 L=1,ILA I=IBASE !OCL NOVREC +!NEC$ ivdep DO 492 IJK=1,ILOT T1=2.0_JPRB*((A(IA+I)-A(IC+I))-B(IB+I)) T2=2.0_JPRB*((A(IA+I)+A(IC+I))-A(IB+I)) @@ -848,6 +862,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 496 IJK=1,ILOT C(JA+J)=2.0_JPRB*((A(IA+I)+A(IC+I))+A(IB+I)) C(JB+J)=2.0_JPRB*((A(IA+I)-A(IC+I))-B(IB+I)) @@ -885,6 +900,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 510 IJK=1,ILOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) C(JB+J)=((A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I)))+ & @@ -930,6 +946,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 530 IJK=1,ILOT ! A10=(A(IA+I)-0.25_JPRB*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)))) & @@ -978,6 +995,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 570 IJK=1,ILOT C(JA+J)=(A(IA+I)+A(IB+I))+A(IC+I) C(JB+J)=(QRT5*(A(IA+I)-A(IB+I))+ & @@ -1008,6 +1026,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 594 L=1,ILA I=IBASE !OCL NOVREC +!NEC$ ivdep DO 592 IJK=1,ILOT T1=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & & +QQRT5*(A(IB+I)-A(IC+I)))-(SSIN72*B(IB+I)+SSIN36*B(IC+I)) @@ -1032,6 +1051,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 596 IJK=1,ILOT C(JA+J)=2.0_JPRB*(A(IA+I)+(A(IB+I)+A(IC+I))) C(JB+J)=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & @@ -1076,6 +1096,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 610 IJK=1,ILOT C(JA+J)=(A(IA+I)+A(ID+I))+(A(IB+I)+A(IC+I)) C(JD+J)=(A(IA+I)-A(ID+I))-(A(IB+I)-A(IC+I)) @@ -1126,6 +1147,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 630 IJK=1,ILOT ! A11= (A(IE+I)+A(IB+I))+(A(IC+I)+A(IF+I)) @@ -1181,6 +1203,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 670 IJK=1,ILOT C(JA+J)=A(IB+I)+(A(IA+I)+A(IC+I)) C(JD+J)=B(IB+I)-(B(IA+I)+B(IC+I)) @@ -1206,6 +1229,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 694 L=1,ILA I=IBASE !OCL NOVREC +!NEC$ ivdep DO 692 IJK=1,ILOT T1=(2.0_JPRB*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & & -(SSIN60*(B(IB+I)+B(IC+I))) @@ -1233,6 +1257,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 696 IJK=1,ILOT C(JA+J)=(2.0_JPRB*(A(IA+I)+A(ID+I)))+ & & (2.0_JPRB*(A(IB+I)+A(IC+I))) @@ -1282,6 +1307,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 820 L=1,ILA I=IBASE !OCL NOVREC +!NEC$ ivdep DO 810 IJK=1,ILOT T2=2.0_JPRB*(((A(IA+I)+A(IE+I))-A(IC+I))-(B(IB+I)-B(ID+I))) T6=2.0_JPRB*(((A(IA+I)+A(IE+I))-A(IC+I))+(B(IB+I)-B(ID+I))) @@ -1312,6 +1338,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 830 IJK=1,ILOT C(JA+J)=2.0_JPRB*(((A(IA+I)+A(IE+I))+A(IC+I))+(A(IB+I)+A(ID+I))) C(JE+J)=2.0_JPRB*(((A(IA+I)+A(IE+I))+A(IC+I))-(A(IB+I)+A(ID+I))) @@ -1455,6 +1482,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 210 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) C(JB+J)=A(IA+I)-A(IB+I) @@ -1481,6 +1509,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 230 IJK=1,ILOT C(JA+J)=A(IA+I)+(C1*A(IB+I)+S1*B(IB+I)) C(JB+J)=A(IA+I)-(C1*A(IB+I)+S1*B(IB+I)) @@ -1505,6 +1534,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 270 IJK=1,ILOT C(JA+J)=A(IA+I) D(JA+J)=-A(IB+I) @@ -1523,6 +1553,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 292 IJK=1,ILOT T1=Z*(A(IA+I)-A(IB+I)) A(IA+I)=Z*(A(IA+I)+A(IB+I)) @@ -1537,6 +1568,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 296 IJK=1,ILOT C(JA+J)=Z*(A(IA+I)+A(IB+I)) C(JB+J)=Z*(A(IA+I)-A(IB+I)) @@ -1568,6 +1600,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 310 IJK=1,ILOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) C(JB+J)=A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I)) @@ -1599,6 +1632,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 330 IJK=1,ILOT A1=(C1*A(IB+I)+S1*B(IB+I))+(C2*A(IC+I)+S2*B(IC+I)) B1=(C1*B(IB+I)-S1*A(IB+I))+(C2*B(IC+I)-S2*A(IC+I)) @@ -1632,6 +1666,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 370 IJK=1,ILOT C(JA+J)=A(IA+I)+0.5_JPRB*(A(IB+I)-A(IC+I)) D(JA+J)=-SIN60*(A(IB+I)+A(IC+I)) @@ -1652,6 +1687,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 392 IJK=1,ILOT T1=Z*(A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I))) T2=ZSIN60*(A(IC+I)-A(IB+I)) @@ -1668,6 +1704,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 396 IJK=1,ILOT C(JA+J)=Z*(A(IA+I)+(A(IB+I)+A(IC+I))) C(JB+J)=Z*(A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I))) @@ -1702,6 +1739,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 410 IJK=1,ILOT C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) @@ -1738,6 +1776,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 430 IJK=1,ILOT A0=A(IA+I)+(C2*A(IC+I)+S2*B(IC+I)) A2=A(IA+I)-(C2*A(IC+I)+S2*B(IC+I)) @@ -1777,6 +1816,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 470 IJK=1,ILOT C(JA+J)=A(IA+I)+SIN45*(A(IB+I)-A(ID+I)) C(JB+J)=A(IA+I)-SIN45*(A(IB+I)-A(ID+I)) @@ -1797,6 +1837,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 492 IJK=1,ILOT T1=Z*(A(IA+I)-A(IC+I)) T3=Z*(A(ID+I)-A(IB+I)) @@ -1815,6 +1856,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 496 IJK=1,ILOT C(JA+J)=Z*((A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I))) C(JC+J)=Z*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) @@ -1852,6 +1894,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 510 IJK=1,ILOT A1=A(IB+I)+A(IE+I) A3=A(IB+I)-A(IE+I) @@ -1899,6 +1942,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 530 IJK=1,ILOT A1=(C1*A(IB+I)+S1*B(IB+I))+(C4*A(IE+I)+S4*B(IE+I)) A3=(C1*A(IB+I)+S1*B(IB+I))-(C4*A(IE+I)+S4*B(IE+I)) @@ -1952,6 +1996,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 570 IJK=1,ILOT A1=A(IB+I)+A(IE+I) A3=A(IB+I)-A(IE+I) @@ -1982,6 +2027,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 592 IJK=1,ILOT A1=A(IB+I)+A(IE+I) A3=A(IB+I)-A(IE+I) @@ -2004,6 +2050,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 596 IJK=1,ILOT A1=A(IB+I)+A(IE+I) A3=A(IB+I)-A(IE+I) @@ -2050,6 +2097,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 610 IJK=1,ILOT A11=(A(IC+I)+A(IF+I))+(A(IB+I)+A(IE+I)) C(JA+J)=(A(IA+I)+A(ID+I))+A11 @@ -2098,6 +2146,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 630 IJK=1,ILOT A1=C1*A(IB+I)+S1*B(IB+I) B1=C1*B(IB+I)-S1*A(IB+I) @@ -2156,6 +2205,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 670 IJK=1,ILOT C(JA+J)=(A(IA+I)+0.5_JPRB*(A(IC+I)-A(IE+I)))+ & & SIN60*(A(IB+I)-A(IF+I)) @@ -2183,6 +2233,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 692 IJK=1,ILOT A11=(A(IC+I)-A(IF+I))+(A(IE+I)-A(IB+I)) T1=Z*((A(IA+I)-A(ID+I))-0.5_JPRB*A11) @@ -2207,6 +2258,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & J=JBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 696 IJK=1,ILOT A11=(A(IC+I)+A(IF+I))+(A(IB+I)+A(IE+I)) C(JA+J)=Z*((A(IA+I)+A(ID+I))+A11) @@ -2254,6 +2306,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC !DEC$ IVDEP +!NEC$ ivdep DO 810 IJK=1,ILOT T3=Z*((A(IA+I)+A(IE+I))-(A(IC+I)+A(IG+I))) T4=Z*((A(ID+I)+A(IH+I))-(A(IB+I)+A(IF+I))) diff --git a/src/trans/external/gath_spec.F90 b/src/trans/external/gath_spec.F90 index e1abc9699..79c1e7247 100644 --- a/src/trans/external/gath_spec.F90 +++ b/src/trans/external/gath_spec.F90 @@ -83,9 +83,13 @@ SUBROUTINE GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LD INTEGER(KIND=JPIM) :: IVSET(KFGATHG) INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J INTEGER(KIND=JPIM) :: IFLD,ICOEFF -INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G +INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G, ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) +INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) +INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) +INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) +INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -112,8 +116,11 @@ SUBROUTINE GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LD ISMAX = R%NSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX ALLOCATE(IDIM0G(0:ISMAX)) +ALLOCATE(IALLMS(ISMAX+1)) +ALLOCATE(IKN(0:ISMAX)) IF(ISMAX /= R%NSMAX) THEN CALL SUWAVEDI(ISMAX,ISMAX,NPRTRW,MYSETW,KPOSSP=IPOSSP,KSPEC2=ISPEC2,& + & KUMPP=IUMPP,KALLMS=IALLMS,KPTRMS=IPTRMS,KSPEC2MX=ISPEC2MX, & & KDIM0G=IDIM0G) ISPEC2_G = (ISMAX+1)*(ISMAX+2) ELSE @@ -121,7 +128,14 @@ SUBROUTINE GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LD ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) + ISPEC2MX = D%NSPEC2MX + IUMPP(:) = D%NUMPP(:) + IALLMS(:) = D%NALLMS(:) + IPTRMS(:) = D%NPTRMS(:) ENDIF +DO J=0,ISMAX + IKN(J)=2*(ISMAX+1-J) +ENDDO IFSEND = 0 IFRECV = 0 @@ -182,7 +196,7 @@ SUBROUTINE GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LD ENDIF CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,& - & ISMAX,ISPEC2,ISPEC2_G,IPOSSP,IDIM0G,LDZA0IP) + & ISMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,LDZA0IP) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('GATH_SPEC',1,ZHOOK_HANDLE) @@ -191,4 +205,3 @@ SUBROUTINE GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LD ! ------------------------------------------------------------------ END SUBROUTINE GATH_SPEC - diff --git a/src/trans/external/setup_trans0.F90 b/src/trans/external/setup_trans0.F90 index 5dcd8cff8..740e3606c 100644 --- a/src/trans/external/setup_trans0.F90 +++ b/src/trans/external/setup_trans0.F90 @@ -12,7 +12,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& & KPRGPNS,KPRGPEW,KPRTRW,KCOMBFLEN,& & LDMPOFF,LDSYNC_TRANS,KTRANS_SYNC_LEVEL,& & LDEQ_REGIONS,K_REGIONS_NS,K_REGIONS_EW,K_REGIONS,& -& PRAD,LDALLOPERM) +& PRAD,LDALLOPERM,KOPT_MEMORY_TR) !**** *SETUP_TRANS0* - General setup routine for transform package @@ -44,6 +44,8 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& ! K_REGIONS_EW - Maximum number of EW partitions ! PRAD - Radius of the planet ! LDALLOPERM - Allocate certain arrays permanently +! KOPT_MEMORY_TR - memory strategy (stack vs heap) in gripoint transpositions + ! The total number of (MPI)-processors has to be equal to KPRGPNS*KPRGPEW ! Method. @@ -62,6 +64,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& ! R. El Khatib 03-01-24 LDMPOFF ! G. Mozdzynski 2006-09-13 LDEQ_REGIONS ! N. Wedi 2009-11-30 add radius +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ @@ -70,7 +73,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, LMPOFF, LSYNC_TRANS, NTRANS_SYNC_LEVEL, MSETUP0, & - & NMAX_RESOL, NPRINTLEV, NPROMATR, LALLOPERM + & NMAX_RESOL, NPRINTLEV, NPROMATR, LALLOPERM, NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : LEQ_REGIONS, NCOMBFLEN, NPRGPEW,NPRGPNS, NPRTRW USE TPM_CONSTANTS ,ONLY : RA @@ -90,6 +93,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& LOGICAL ,OPTIONAL,INTENT(IN) :: LDEQ_REGIONS LOGICAL ,OPTIONAL,INTENT(IN) :: LDALLOPERM REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PRAD +INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KOPT_MEMORY_TR INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS(:) INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_NS INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_EW @@ -123,6 +127,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& LEQ_REGIONS=.FALSE. RA=6371229._JPRB LALLOPERM=.FALSE. +NSTACK_MEMORY_TR=0 ! Optional arguments @@ -173,6 +178,9 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& IF(PRESENT(LDEQ_REGIONS)) THEN LEQ_REGIONS = LDEQ_REGIONS ENDIF +IF(PRESENT(KOPT_MEMORY_TR))THEN + NSTACK_MEMORY_TR = KOPT_MEMORY_TR +ENDIF ! Initial setup CALL SUMP_TRANS0 diff --git a/src/trans/include/ectrans/setup_trans0.h b/src/trans/include/ectrans/setup_trans0.h index d05820ee6..b716f60b2 100644 --- a/src/trans/include/ectrans/setup_trans0.h +++ b/src/trans/include/ectrans/setup_trans0.h @@ -13,7 +13,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& & KPRGPNS,KPRGPEW,KPRTRW,KCOMBFLEN,& & LDMPOFF,LDSYNC_TRANS,KTRANS_SYNC_LEVEL,& & LDEQ_REGIONS,K_REGIONS_NS,K_REGIONS_EW,K_REGIONS,& -& PRAD,LDALLOPERM) +& PRAD,LDALLOPERM,KOPT_MEMORY_TR) !**** *SETUP_TRANS0* - General setup routine for transform package @@ -45,6 +45,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& ! K_REGIONS_EW - Maximum number of EW partitions ! PRAD - Radius of the planet ! LDALLOPERM - Allocate certain arrays permanently +! KOPT_MEMORY_TR - memory strategy (stack vs heap) in gripoint transpositions ! The total number of (MPI)-processors has to be equal to KPRGPNS*KPRGPEW @@ -64,6 +65,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& ! R. El Khatib 03-01-24 LDMPOFF ! G. Mozdzynski 2006-09-13 LDEQ_REGIONS ! N. Wedi 2009-11-30 add radius +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ @@ -79,6 +81,7 @@ INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KTRANS_SYNC_LEVEL LOGICAL ,OPTIONAL,INTENT(IN) :: LDEQ_REGIONS LOGICAL ,OPTIONAL,INTENT(IN) :: LDALLOPERM REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PRAD +INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KOPT_MEMORY_TR INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS(:) INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_NS INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_EW diff --git a/src/trans/internal/dist_spec_control_mod.F90 b/src/trans/internal/dist_spec_control_mod.F90 index f2e090d7b..05bb1cf76 100644 --- a/src/trans/internal/dist_spec_control_mod.F90 +++ b/src/trans/internal/dist_spec_control_mod.F90 @@ -54,7 +54,9 @@ SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& ! -------------- ! Original : 2000-04-01 ! P.Marguinaud : 2014-10-10 -! R. El Khatib 25-Jul-2019 Optimization by vectorization, proper non-blocking comms and overlapp send/recv with pack/unpack +! R. El Khatib 25-Jul-2019 Optimization by vectorization, proper non-blocking comms +! and overlapp send/recv with pack/unpack +! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB @@ -65,11 +67,11 @@ SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& IMPLICIT NONE -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPECG(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN), CONTIGUOUS :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT), CONTIGUOUS :: PSPEC(:,:) LOGICAL , INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 @@ -87,7 +89,7 @@ SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& REAL(KIND=JPRB), ALLOCATABLE :: ZBUF(:,:,:) INTEGER(KIND=JPIM) :: IASM0G(0:KSMAX) INTEGER(KIND=JPIM) :: JM,JN,IFLDR,IFLD,JFLD,ITAG,JNM,ILEN(NPRTRW),JA,ISND(NPRTRV,NPRTRW), JB, IFLDOFF -INTEGER(KIND=JPIM) :: IRCV,ISTP(NPRTRW),ISENDREQ(NPROC), IREQRCV(NPROC), IPROC(NPROC), JMLOC, IFLDBUF, IFLDSPG, IPOSSP +INTEGER(KIND=JPIM) :: IRCV,ISENDREQ(NPROC), IREQRCV(NPROC), IPROC(NPROC), JMLOC, IFLDBUF, IFLDSPG, IPOSSP INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, IPOS0,ISENT, INR, IOFFPROC(NPROC+1), IFLDLOC(KFDISTG), IOFF, ILOCFLD(KFDISTG) INTEGER(KIND=JPIM), POINTER :: ISORT (:) @@ -107,7 +109,6 @@ SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& DO JA=1,NPRTRW ILEN(JA) = KPOSSP(JA+1)-KPOSSP(JA) - ISTP(JA) = KPOSSP(JA+1)-1 ENDDO DO JA=1,NPRTRW DO JB=1,NPRTRV diff --git a/src/trans/internal/ftdir_ctl_mod.F90 b/src/trans/internal/ftdir_ctl_mod.F90 index 45a82b50f..6b1a35210 100644 --- a/src/trans/internal/ftdir_ctl_mod.F90 +++ b/src/trans/internal/ftdir_ctl_mod.F90 @@ -52,13 +52,13 @@ SUBROUTINE FTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & ! Modifications. ! -------------- ! Original : 00-03-03 - +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR +! R. El Khatib 01-Jun-2022 contiguous pointer ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB -!USE TPM_DIM -!USE TPM_GEOMETRY +USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_TRANS ,ONLY : FOUBUF_IN USE TPM_DISTR ,ONLY : D, MYPROC, NPROC @@ -85,7 +85,9 @@ SUBROUTINE FTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP2(:,:,:) ! Local variables -REAL(KIND=JPRB) :: ZGTF(KF_FS,D%NLENGTF) +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER, CONTIGUOUS :: ZGTF(:,:) INTEGER(KIND=JPIM) :: IST,JGL,IGL,IBLEN INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) @@ -141,6 +143,19 @@ SUBROUTINE FTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & IST = IST+KF_SCALARS_G ENDIF +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) +! Now, force the OS to allocate this shared array right now, not when it starts +! to be used which is an OPEN-MP loop, that would cause a threads +! synchronization lock : + IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN + ZGTF_HEAP(1,1)=HUGE(1._JPRB) + ENDIF + ZGTF => ZGTF_HEAP(:,:) +ENDIF + ! Transposition CALL GSTATS(158,0) diff --git a/src/trans/internal/ftdir_ctlad_mod.F90 b/src/trans/internal/ftdir_ctlad_mod.F90 index 9b08b5e64..8b234a264 100644 --- a/src/trans/internal/ftdir_ctlad_mod.F90 +++ b/src/trans/internal/ftdir_ctlad_mod.F90 @@ -52,14 +52,13 @@ SUBROUTINE FTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & ! Modifications. ! -------------- ! Original : 00-03-03 +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB -!USE TPM_GEN -!USE TPM_DIM -!USE TPM_GEOMETRY +USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE TRLTOG_MOD ,ONLY : TRLTOG @@ -85,8 +84,9 @@ SUBROUTINE FTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP2(:,:,:) ! Local variables -REAL(KIND=JPRB) :: ZGTF(KF_FS,D%NLENGTF) - +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER :: ZGTF(:,:) INTEGER(KIND=JPIM) :: IST INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) @@ -102,6 +102,18 @@ SUBROUTINE FTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & CALL GSTATS(133,0) +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) +! Now, force the OS to allocate this shared array right now, not when it starts +! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : + IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN + ZGTF_HEAP(1,1)=HUGE(1._JPRB) + ENDIF + ZGTF => ZGTF_HEAP(:,:) +ENDIF + IF(MYPROC > NPROC/2)THEN IBEG=1 IEND=D%NDGL_FS diff --git a/src/trans/internal/ftdir_mod.F90 b/src/trans/internal/ftdir_mod.F90 index 0aafbdb13..8c8ad6acc 100644 --- a/src/trans/internal/ftdir_mod.F90 +++ b/src/trans/internal/ftdir_mod.F90 @@ -61,7 +61,7 @@ SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL -REAL(KIND=JPRB), INTENT(INOUT) :: PREEL(:,:) +REAL(KIND=JPRB), POINTER, CONTIGUOUS, INTENT(INOUT) :: PREEL(:,:) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,IST1 INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN, ITYPE @@ -113,9 +113,7 @@ SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) IST1=1 IF (G%NLOEN(IGLG)==1) IST1=0 DO JJ=IST1,ILEN - DO JF=1,KFIELDS - PREEL(JF,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRB - ENDDO + PREEL(1:KFIELDS,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRB ENDDO ! ------------------------------------------------------------------ diff --git a/src/trans/internal/ftinv_ctl_mod.F90 b/src/trans/internal/ftinv_ctl_mod.F90 index 601dd282c..3b00632e2 100644 --- a/src/trans/internal/ftinv_ctl_mod.F90 +++ b/src/trans/internal/ftinv_ctl_mod.F90 @@ -57,14 +57,13 @@ SUBROUTINE FTINV_CTL(KF_UV_G,KF_SCALARS_G,& ! Modifications. ! -------------- ! Original : 00-03-03 +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB -USE TPM_GEN ,ONLY : NERR -!USE TPM_DIM -!USE TPM_GEOMETRY +USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR USE TPM_TRANS ,ONLY : FOUBUF, LDIVGP, LSCDERS, LUVDER, LVORGP,LATLON USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE TPM_FLT ,ONLY : S @@ -114,16 +113,10 @@ SUBROUTINE FTINV_CTL(KF_UV_G,KF_SCALARS_G,& #else REAL(KIND=JPRB),TARGET,ALLOCATABLE :: ZDUM(:,:) ! When using this (HEAP) alloc Cray CCE 8.6.2 fails in OMP 1639 #endif -!REAL(KIND=JPRB),TARGET :: ZGTF(KF_FS,D%NLENGTF) ! A stack hog ? -REAL(KIND=JPRB),TARGET,ALLOCATABLE :: ZGTF(:,:) ! (KF_FS,D%NLENGTF) -ALLOCATE(ZGTF(KF_FS,D%NLENGTF)) -! Certain compilers allocate arrays at the moment they start to be used, not at the moment the user -! allocates them. This is a problem if that moment is an open-mp loop because it would trigger -! an omp barrier to let the array be allocated by the master thread if the array is shared (which -! is the case here for zgtf). -! Therefore the next line ensures zgtf is really allocated here, not inside the omp loop. REK -IF (KF_FS > 0 .AND. D%NLENGTF > 0) ZGTF(1,1)=0._JPRB +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER :: ZGTF(:,:) #if 1 ALLOCATE(ZDUM(1,D%NLENGTF)) @@ -141,6 +134,18 @@ SUBROUTINE FTINV_CTL(KF_UV_G,KF_SCALARS_G,& CALL GSTATS(107,0) +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) +! Now, force the OS to allocate this shared array right now, not when it starts +! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : + IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN + ZGTF_HEAP(1,1)=HUGE(1._JPRB) + ENDIF + ZGTF => ZGTF_HEAP(:,:) +ENDIF + IF (KF_UV > 0 .OR. KF_SCDERS > 0 .OR. (LATLON.AND.S%LDLL) ) THEN IST = 1 IF (LVORGP) THEN @@ -291,7 +296,7 @@ SUBROUTINE FTINV_CTL(KF_UV_G,KF_SCALARS_G,& ! ------------------------------------------------------------------ -DEALLOCATE(ZGTF) +!DEALLOCATE(ZGTF) END SUBROUTINE FTINV_CTL END MODULE FTINV_CTL_MOD diff --git a/src/trans/internal/ftinv_ctlad_mod.F90 b/src/trans/internal/ftinv_ctlad_mod.F90 index ad5877903..cceda716b 100644 --- a/src/trans/internal/ftinv_ctlad_mod.F90 +++ b/src/trans/internal/ftinv_ctlad_mod.F90 @@ -58,14 +58,13 @@ SUBROUTINE FTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& ! Modifications. ! -------------- ! Original : 00-03-03 +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB -USE TPM_GEN ,ONLY : NERR -!USE TPM_DIM -!USE TPM_GEOMETRY +USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR USE TPM_TRANS ,ONLY : FOUBUF, LDIVGP, LSCDERS, LUVDER, LVORGP USE TPM_DISTR ,ONLY : D, MYPROC, NPROC @@ -100,7 +99,9 @@ SUBROUTINE FTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& ! ------------------------------------------------------------------ -REAL(KIND=JPRB),TARGET :: ZGTF(KF_FS,D%NLENGTF) +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER :: ZGTF(:,:) REAL(KIND=JPRB),TARGET :: ZDUM(1,D%NLENGTF) REAL(KIND=JPRB),POINTER :: ZUV(:,:) REAL(KIND=JPRB),POINTER :: ZSCALAR(:,:) @@ -195,6 +196,18 @@ SUBROUTINE FTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& ENDIF ENDIF +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) +! Now, force the OS to allocate this shared array right now, not when it starts +! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : + IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN + ZGTF_HEAP(1,1)=HUGE(1._JPRB) + ENDIF + ZGTF => ZGTF_HEAP(:,:) +ENDIF + CALL GSTATS(182,0) CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& &PGP,PGPUV,PGP3A,PGP3B,PGP2) diff --git a/src/trans/internal/gath_spec_control_mod.F90 b/src/trans/internal/gath_spec_control_mod.F90 index 7333653f7..c481889bc 100644 --- a/src/trans/internal/gath_spec_control_mod.F90 +++ b/src/trans/internal/gath_spec_control_mod.F90 @@ -11,7 +11,7 @@ MODULE GATH_SPEC_CONTROL_MOD CONTAINS SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& - & KSMAX,KSPEC2,KSPEC2_G,KPOSSP,KDIM0G,LDZA0IP) + & KSMAX,KSPEC2,KSPEC2MX,KSPEC2G,KPOSSP,KDIM0G,KUMPP,KALLMS,KPTRMS,KN,LDZA0IP) !**** *GATH_SPEC_CONTROL* - Gather global spectral array from processors @@ -26,28 +26,45 @@ SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array -! KFGATHG - Global number of fields to be distributed +! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for distributing each field ! KVSET(:) - "B-Set" for each field ! PSPEC(:,:) - Local spectral array -! LDZA0IP - Set first coefficients (imaginary part) to zero +! LDIM1_IS_FLD - .TRUE. if first dimension contains the fields +! KSMAX - Spectral truncation limit +! KSPEC2 - Local number of spectral coefficients +! KSPEC2MX - Maximum local number of spectral coefficients +! KSPEC2G - Global number of spectral coefficients +! KPOSSP - Position of local waves for each task +! KDIM0G - Defines partitioning of global spectral fields among PEs +! KUMPP - Number of spectral waves on this a-set +! KALLMS - Wave numbers for all a-set concatenated together to give all wave numbers in a-set order +! KPTRMS - Pointer to the first wave number of a given a-set in kallms array. +! KN - Number of spectral coefficients for each m wave +! LDZA0IP - Set first coefficients (imaginary part) to zero (global model only) +! Externals. SET2PE - compute "A and B" set from PE +! ---------- MPL.. - message passing routines + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 2000-04-01 +! R. El Khatib 02-Dec-2020 re-write for optimizations and merge with LAM counterpart ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB -USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & +USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD -!USE TPM_GEN -!USE TPM_DIM -USE TPM_DISTR ,ONLY : MTAGDISTSP, NPRCIDS, NPRTRW, & - & MYSETV, MYSETW, MYPROC, NPROC +USE TPM_DISTR ,ONLY : MTAGDISTSP, NPRCIDS, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC, NPRTRV USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS - USE SET2PE_MOD ,ONLY : SET2PE -!USE SUWAVEDI_MOD -! +USE TPM_GEOMETRY ,ONLY : G IMPLICIT NONE @@ -59,175 +76,234 @@ SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 -INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2_G +INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2MX +INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2G INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KUMPP(NPRTRW) +INTEGER(KIND=JPIM) , INTENT(IN) :: KALLMS(KSMAX+1) +INTEGER(KIND=JPIM) , INTENT(IN) :: KPTRMS(NPRTRW) +INTEGER(KIND=JPIM) , INTENT(IN) :: KN(0:KSMAX) LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP -REAL(KIND=JPRB) :: ZFLD(KSPEC2,KFGATHG),ZDUM(KSPEC2) -REAL(KIND=JPRB),ALLOCATABLE :: ZRECV(:,:) -INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,IBSET,ILEN,JA,ISND -INTEGER(KIND=JPIM) :: IRCV,ISP,ILENR,ISTA,ISTP,ISENDREQ(KFGATHG),IPOS0,JNM -INTEGER(KIND=JPIM) :: IDIST(KSPEC2_G),IMYFIELDS +REAL(KIND=JPRB) :: ZBUFSEND(KSPEC2MX,COUNT(KVSET(1:KFGATHG) == MYSETV)) +REAL(KIND=JPRB) :: ZRECV(KSPEC2MX,COUNT(KTO(1:KFGATHG) == MYPROC)) +INTEGER(KIND=JPIM) :: IASM0G(0:KSMAX) +INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,IB,ILEN(NPRTRW),JA,JB,ISND,JMLOC +INTEGER(KIND=JPIM) :: IPE(NPRTRV,NPRTRW),ILENR,ISENDREQ(NPROC),IPOSSP,JNM,JROC +INTEGER(KIND=JPIM) :: IFLD,IFLDLOC(COUNT(KTO(1:KFGATHG) == MYPROC)),IOFFPROC +INTEGER(KIND=JPIM) :: ILOCFLD(COUNT(KVSET(1:KFGATHG) == MYSETV)) LOGICAL :: LLZA0IP ! ------------------------------------------------------------------ -LLZA0IP=.TRUE. +! Compute help array for distribution + +DO JA=1,NPRTRW + ILEN(JA) = KPOSSP(JA+1)-KPOSSP(JA) +ENDDO +DO JA=1,NPRTRW + DO JB=1,NPRTRV + CALL SET2PE(IPE(JB,JA),0,0,JA,JB) + ENDDO +ENDDO +IASM0G(0)=1 +DO JM=1,KSMAX + IASM0G(JM)=IASM0G(JM-1)+KN(JM-1) +ENDDO + +LLZA0IP=.NOT.G%LAM ! or it should have been coded in the original code, please :-( IF (PRESENT (LDZA0IP)) LLZA0IP=LDZA0IP !GATHER SPECTRAL ARRAY -IF( NPROC == 1 ) THEN - CALL GSTATS(1644,0) - IF(LDIM1_IS_FLD) THEN -!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) - DO JM=1,KSPEC2_G +!Send +ISND=0 +IOFFPROC=0 +IF (KSPEC2 > 0) THEN + CALL GSTATS(810,0) + DO JROC=1,NPROC + IF (JROC /= MYPROC) THEN + IFLD=0 ! counter of fields in PSPEC + IFLDS=0 ! counter of fields in ZBUFSEND DO JFLD=1,KFGATHG - PSPECG(JFLD,JM) =PSPEC(JFLD,JM) + IF (KVSET(JFLD) == MYSETV) THEN + IFLD=IFLD+1 + IF (JROC==KTO(JFLD)) THEN + IFLDS=IFLDS+1 + IF (LDIM1_IS_FLD) THEN + ZBUFSEND(1:KSPEC2,IOFFPROC+IFLDS)=PSPEC(IFLD,1:KSPEC2) + ELSE + ZBUFSEND(1:KSPEC2,IOFFPROC+IFLDS)=PSPEC(1:KSPEC2,IFLD) + ENDIF + ENDIF + ENDIF + ENDDO + IF (IFLDS > 0) THEN + ITAG=MTAGDISTSP+MYPROC + ISND=ISND+1 + CALL MPL_SEND(ZBUFSEND(:,IOFFPROC+1:IOFFPROC+IFLDS),KDEST=NPRCIDS(JROC),KTAG=ITAG,& + & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISND),& + & CDSTRING='GATH_SPEC_CONTROL') + ENDIF + IOFFPROC=IOFFPROC+IFLDS + ENDIF + ENDDO + CALL GSTATS(810,1) + +! Myself : + IFLD=0 + IFLDR=0 + DO JFLD=1,KFGATHG + IF (KTO(JFLD) == MYPROC) THEN + IFLD=IFLD+1 + IF (KVSET(JFLD)==MYSETV) THEN + IFLDR = IFLDR+1 + IFLDLOC(IFLDR)=IFLD + ENDIF + ENDIF + ENDDO + IFLD=0 + IFLDR=0 + DO JFLD=1,KFGATHG + IF (KVSET(JFLD)==MYSETV) THEN + IFLD=IFLD+1 + IF (KTO(JFLD) == MYPROC) THEN + IFLDR = IFLDR+1 + ILOCFLD(IFLDR)=IFLD + ENDIF + ENDIF + ENDDO + IF (IFLDR > 0) THEN + IF (LDIM1_IS_FLD) THEN + CALL GSTATS(1644,0) +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) + DO JFLD=1,IFLDR + DO JMLOC=1,KUMPP(MYSETW) + JM=KALLMS(KPTRMS(MYSETW)+JMLOC-1) + IPOSSP=KDIM0G(JM)-KPOSSP(MYSETW)+1 + PSPECG(IFLDLOC(JFLD),IASM0G(JM):IASM0G(JM)+KN(JM)-1)=PSPEC(ILOCFLD(JFLD),IPOSSP:IPOSSP+KN(JM)-1) + ENDDO + IF (LLZA0IP) THEN + II = 0 + DO JN=0,KSMAX + II = II+2 + PSPECG(IFLDLOC(JFLD),II) = 0.0_JPRB + ENDDO + ENDIF ENDDO - ENDDO !$OMP END PARALLEL DO - ELSE -!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) - DO JFLD=1,KFGATHG - DO JM=1,KSPEC2_G - PSPECG(JM,JFLD) =PSPEC(JM,JFLD) + CALL GSTATS(1644,1) + ELSE + CALL GSTATS(1644,0) +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) + DO JFLD=1,IFLDR + DO JMLOC=1,KUMPP(MYSETW) + JM=KALLMS(KPTRMS(MYSETW)+JMLOC-1) + IPOSSP=KDIM0G(JM)-KPOSSP(MYSETW)+1 + PSPECG(IASM0G(JM):IASM0G(JM)+KN(JM)-1,IFLDLOC(JFLD))=PSPEC(IPOSSP:IPOSSP+KN(JM)-1,ILOCFLD(JFLD)) + ENDDO + IF (LLZA0IP) THEN + II = 0 + DO JN=0,KSMAX + II = II+2 + PSPECG(II,IFLDLOC(JFLD)) = 0.0_JPRB + ENDDO + ENDIF ENDDO - ENDDO !$OMP END PARALLEL DO - ENDIF - CALL GSTATS(1644,1) -ELSE - IMYFIELDS = 0 - DO JFLD=1,KFGATHG - IF(KTO(JFLD) == MYPROC) THEN - IMYFIELDS = IMYFIELDS+1 + CALL GSTATS(1644,1) ENDIF - ENDDO - IF(IMYFIELDS>0) THEN - ALLOCATE(ZRECV(KSPEC2_G,IMYFIELDS)) - II = 0 - CALL GSTATS(1804,0) - DO JM=0,KSMAX - DO JN=JM,KSMAX - IDIST(II+1) = KDIM0G(JM)+(JN-JM)*2 - IDIST(II+2) = KDIM0G(JM)+(JN-JM)*2+1 - II = II+2 - ENDDO - ENDDO - CALL GSTATS(1804,1) ENDIF - CALL GSTATS_BARRIER(788) - - !Send - CALL GSTATS(810,0) - IFLDS = 0 - IF(KSPEC2 > 0 )THEN - DO JFLD=1,KFGATHG - - IBSET = KVSET(JFLD) - IF( IBSET == MYSETV )THEN - - IFLDS = IFLDS+1 - ISND = KTO(JFLD) - ITAG = MTAGDISTSP+JFLD+17 - IF(LDIM1_IS_FLD) THEN - ZFLD(1:KSPEC2,IFLDS)=PSPEC(IFLDS,1:KSPEC2) - CALL MPL_SEND(ZFLD(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& - &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& - &CDSTRING='GATH_SPEC_CONTROL') - ELSE - CALL MPL_SEND(PSPEC(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& - &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& - &CDSTRING='GATH_SPEC_CONTROL') - ENDIF - ENDIF - ENDDO - ENDIF +ENDIF - ! Recieve - IFLDR = 0 - DO JFLD=1,KFGATHG - IF(KTO(JFLD) == MYPROC) THEN - IBSET = KVSET(JFLD) - IFLDR = IFLDR+1 - DO JA=1,NPRTRW - ILEN = KPOSSP(JA+1)-KPOSSP(JA) - IF( ILEN > 0 )THEN - CALL SET2PE(IRCV,0,0,JA,IBSET) - ITAG = MTAGDISTSP+JFLD+17 - ISTA = KPOSSP(JA) - ISTP = ISTA+ILEN-1 - CALL MPL_RECV(ZRECV(ISTA:ISTP,IFLDR),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& - &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & - &CDSTRING='GATH_SPEC_CONTROL') - IF( ILENR /= ILEN )THEN - WRITE(0,'("GATH_SPEC_CONTROL: JFLD=",I4," JA=",I4," ILEN=",I10," ILENR=",I10)')& - &JFLD,JA,ILEN,ILENR +! Receive +DO JA=1,NPRTRW + IF (ILEN(JA) > 0) THEN + DO JB=1,NPRTRV + IF (IPE(JB,JA) /= MYPROC) THEN + ! Locate received fields in source array : + IFLD=0 + IFLDR=0 + DO JFLD=1,KFGATHG + IF (KTO(JFLD) == MYPROC) THEN + IFLD=IFLD+1 + IF (KVSET(JFLD)==JB) THEN + IFLDR = IFLDR+1 + IFLDLOC(IFLDR)=IFLD + ENDIF + ENDIF + ENDDO + IF (IFLDR > 0) THEN + ITAG=MTAGDISTSP+IPE(JB,JA) + CALL GSTATS(810,0) + CALL MPL_RECV(ZRECV(:,1:IFLDR),KSOURCE=NPRCIDS(IPE(JB,JA)),KTAG=ITAG,& + & KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & + & CDSTRING='GATH_SPEC_CONTROL') + IF (ILENR /= KSPEC2MX*IFLDR) THEN CALL ABORT_TRANS('GATH_SPEC_CONTROL:INVALID RECEIVE MESSAGE LENGTH') ENDIF + CALL GSTATS(810,1) + CALL GSTATS(1644,0) + IF (LDIM1_IS_FLD) THEN +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) + DO JFLD=1,IFLDR + DO JMLOC=1,KUMPP(JA) + JM=KALLMS(KPTRMS(JA)+JMLOC-1) + IPOSSP=KDIM0G(JM)-KPOSSP(JA)+1 + PSPECG(IFLDLOC(JFLD),IASM0G(JM):IASM0G(JM)+KN(JM)-1)=ZRECV(IPOSSP:IPOSSP+KN(JM)-1,JFLD) + ENDDO + IF (LLZA0IP) THEN + II = 0 + DO JN=0,KSMAX + II = II+2 + PSPECG(IFLDLOC(JFLD),II) = 0.0_JPRB + ENDDO + ENDIF + ENDDO +!$OMP END PARALLEL DO + ELSE +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) + DO JFLD=1,IFLDR + DO JMLOC=1,KUMPP(JA) + JM=KALLMS(KPTRMS(JA)+JMLOC-1) + IPOSSP=KDIM0G(JM)-KPOSSP(JA)+1 + PSPECG(IASM0G(JM):IASM0G(JM)+KN(JM)-1,IFLDLOC(JFLD))=ZRECV(IPOSSP:IPOSSP+KN(JM)-1,JFLD) + ENDDO + IF (LLZA0IP) THEN + II = 0 + DO JN=0,KSMAX + II = II+2 + PSPECG(II,IFLDLOC(JFLD)) = 0.0_JPRB + ENDDO + ENDIF + ENDDO +!$OMP END PARALLEL DO + ENDIF + CALL GSTATS(1644,1) ENDIF - ENDDO - ENDIF - ENDDO - - ! Check for completion of sends - IF(KSPEC2 > 0 )THEN - DO JFLD=1,KFGATHG - IBSET = KVSET(JFLD) - IF( IBSET == MYSETV )THEN - CALL MPL_WAIT(KREQUEST=ISENDREQ(JFLD), & - & CDSTRING='GATH_GRID_CTL: WAIT') ENDIF ENDDO ENDIF - CALL GSTATS(810,1) - CALL GSTATS_BARRIER2(788) - - CALL GSTATS(1644,0) -!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JNM,II,JN,ISP) - DO JFLD=1,IMYFIELDS - IF(LDIM1_IS_FLD) THEN - DO JNM=1,KSPEC2_G - PSPECG(JFLD,JNM) = ZRECV(IDIST(JNM),JFLD) - ENDDO - IF (LLZA0IP) THEN - II = 0 - DO JN=0,KSMAX - ISP = KDIM0G(0)+JN*2+1 - II = II+2 - PSPECG(JFLD,II) = 0.0_JPRB - ENDDO - ENDIF - ELSE - DO JNM=1,KSPEC2_G - PSPECG(JNM,JFLD) = ZRECV(IDIST(JNM),JFLD) - ENDDO - IF (LLZA0IP) THEN - II = 0 - DO JN=0,KSMAX - ISP = KDIM0G(0)+JN*2+1 - II = II+2 - PSPECG(II,JFLD) = 0.0_JPRB - ENDDO - ENDIF - ENDIF - ENDDO -!$OMP END PARALLEL DO - CALL GSTATS(1644,1) - IF(ALLOCATED(ZRECV)) DEALLOCATE(ZRECV) +ENDDO +CALL GSTATS_BARRIER2(788) - !Synchronize processors - CALL GSTATS(785,0) - CALL MPL_BARRIER(CDSTRING='GATH_SPEC_CONTROL:') - CALL GSTATS(785,1) +! Check for completion of sends +CALL GSTATS(810,0) +IF (ISND > 0) THEN + CALL MPL_WAIT(ISENDREQ(1:ISND),CDSTRING='GATH_GRID_CTL: WAIT') ENDIF +CALL GSTATS(810,1) + +!Synchronize processors. Useful ?? +CALL GSTATS(785,0) +!rekCALL MPL_BARRIER(CDSTRING='GATH_SPEC_CONTROL:') +CALL GSTATS(785,1) + +CALL GSTATS_BARRIER(788) ! ------------------------------------------------------------------ END SUBROUTINE GATH_SPEC_CONTROL END MODULE GATH_SPEC_CONTROL_MOD - - diff --git a/src/trans/internal/gpnorm_trans_ctl_mod.F90 b/src/trans/internal/gpnorm_trans_ctl_mod.F90 index 13b236908..4c18db54b 100644 --- a/src/trans/internal/gpnorm_trans_ctl_mod.F90 +++ b/src/trans/internal/gpnorm_trans_ctl_mod.F90 @@ -48,6 +48,7 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) ! Original : 19th Sept 2008 ! R. El Khatib 07-08-2009 Optimisation directive for NEC ! R. El Khatib 16-Sep-2019 merge with LAM code +! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD @@ -154,6 +155,7 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) ENDDO ALLOCATE(ZGTF(IF_FS,D%NLENGTF)) +IF (SIZE(ZGTF) > 0) ZGTF(1,1)=0._JPRB ! force allocation right here, not inside an omp region below LGPNORM=.TRUE. CALL TRGTOL(ZGTF,IF_FS,IF_GP,IF_SCALARS_G,IVSET,PGP=PGP) LGPNORM=.FALSE. diff --git a/src/trans/internal/tpm_gen.F90 b/src/trans/internal/tpm_gen.F90 index 16e896978..f2ac76b4f 100644 --- a/src/trans/internal/tpm_gen.F90 +++ b/src/trans/internal/tpm_gen.F90 @@ -39,6 +39,11 @@ MODULE TPM_GEN ! 2 = Use buffered SENDs, use blocking RECVs, add barrier at the end of each cycle INTEGER(KIND=JPIM) :: NTRANS_SYNC_LEVEL = 0 +! NSTACK_MEMORY_TR : optional memory strategy in gridpoint transpositions +! = 0 : prefer heap (slower but less memory consuming) +! > 0 : prefer stack (faster but more memory consuming) +INTEGER(KIND=JPIM) :: NSTACK_MEMORY_TR = 0 + LOGICAL, ALLOCATABLE :: LENABLED(:) ! true: the resolution is enabled (it has been ! initialised and has not been released afterward) diff --git a/src/trans/internal/trgtol_mod.F90 b/src/trans/internal/trgtol_mod.F90 index 042d8d566..0732eddd5 100644 --- a/src/trans/internal/trgtol_mod.F90 +++ b/src/trans/internal/trgtol_mod.F90 @@ -11,7 +11,7 @@ MODULE TRGTOL_MOD PUBLIC TRGTOL -PRIVATE TRGTOL_PROLOG, TRGTOL_COMM +PRIVATE TRGTOL_PROLOG, TRGTOL_COMM, TRGTOL_COMM_HEAP, TRGTOL_COMM_STACK CONTAINS @@ -50,11 +50,13 @@ SUBROUTINE TRGTOL(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& ! Modifications. ! -------------- ! Original : 18-Aug-2014 from trgtol +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC USE TPM_TRANS ,ONLY : NGPBLKS @@ -91,9 +93,15 @@ SUBROUTINE TRGTOL(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& CALL TRGTOL_PROLOG(KF_FS,KF_GP,KVSET,& & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND) -CALL TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, & - & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, & - & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) +IF (NSTACK_MEMORY_TR==0) THEN + CALL TRGTOL_COMM_HEAP(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, & + & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) +ELSE + CALL TRGTOL_COMM_STACK(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, & + & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) +ENDIF IF (LHOOK) CALL DR_HOOK('TRGTOL',1,ZHOOK_HANDLE) @@ -257,8 +265,102 @@ SUBROUTINE TRGTOL_PROLOG(KF_FS,KF_GP,KVSET,& END SUBROUTINE TRGTOL_PROLOG +SUBROUTINE TRGTOL_COMM_HEAP(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC +USE TPM_TRANS ,ONLY : NGPBLKS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP +REAL(KIND=JPRB),INTENT(OUT) :: PGLAT(KF_FS,D%NLENGTF) +INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(KF_GP) +INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KNSEND +INTEGER(KIND=JPIM), INTENT(IN) :: KNRECV +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSEND (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECV (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF) +INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP2(:,:,:) + +REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFS(:,:) +REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFR(:,:) + +ALLOCATE(ZCOMBUFS(-1:KSENDCOUNT,KNSEND)) +! Now, force the OS to allocate this shared array right now, not when it starts to be used which is +! an OPEN-MP loop, that would cause a threads synchronization lock : +IF (KNSEND > 0 .AND. KSENDCOUNT >=-1) ZCOMBUFS(-1,1)=HUGE(1._JPRB) +ALLOCATE(ZCOMBUFR(-1:KRECVCOUNT,KNRECV)) + +CALL TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & ZCOMBUFS,ZCOMBUFR, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) + +DEALLOCATE(ZCOMBUFR) +DEALLOCATE(ZCOMBUFS) + +END SUBROUTINE TRGTOL_COMM_HEAP + +SUBROUTINE TRGTOL_COMM_STACK(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC +USE TPM_TRANS ,ONLY : NGPBLKS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP +REAL(KIND=JPRB),INTENT(OUT) :: PGLAT(KF_FS,D%NLENGTF) +INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(KF_GP) +INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KNSEND +INTEGER(KIND=JPIM), INTENT(IN) :: KNRECV +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSEND (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECV (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF) +INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP2(:,:,:) + +REAL(KIND=JPRB) :: ZCOMBUFS(-1:KSENDCOUNT,KNSEND) +REAL(KIND=JPRB) :: ZCOMBUFR(-1:KRECVCOUNT,KNRECV) + +CALL TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & ZCOMBUFS,ZCOMBUFR, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) + +END SUBROUTINE TRGTOL_COMM_STACK + SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & PCOMBUFS,PCOMBUFR, & & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *TRGTOL_COMM * - transposition of grid point data from column @@ -304,7 +406,7 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ! : 98-06-17 add mailbox control logic (from TRLTOM) ! =99-03-29= Mats Hamrud and Deborah Salmond ! JUMP in FFT's changed to 1 -! KINDEX introduced and ZCOMBUF not used for same PE +! KINDEX introduced and PCOMBUF not used for same PE ! 01-11-23 Deborah Salmond and John Hague ! LIMP_NOOLAP Option for non-overlapping message passing ! and buffer packing @@ -313,11 +415,12 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ! 03-04-02 G. Radnoti: call barrier always when nproc>1 ! 08-01-01 G.Mozdzynski: cleanup ! 09-01-02 G.Mozdzynski: use non-blocking recv and send +! R. El Khatib 09-Sep-2020 64 bits addressing for PGLAT ! ------------------------------------------------------------------ -USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPIA USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY, & @@ -349,6 +452,8 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF) INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC) INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS) +REAL(KIND=JPRB), INTENT(INOUT) :: PCOMBUFS(-1:KSENDCOUNT,KNSEND) +REAL(KIND=JPRB), INTENT(INOUT) :: PCOMBUFR(-1:KRECVCOUNT,KNRECV) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) @@ -356,9 +461,6 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP2(:,:,:) -REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFS(:,:) -REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFR(:,:) - INTEGER(KIND=JPIM) :: IPOSPLUS(KNSEND) INTEGER(KIND=JPIM) :: ISETW(KNSEND) INTEGER(KIND=JPIM) :: IJPOS(NGPBLKS,KNSEND) @@ -375,6 +477,8 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& INTEGER(KIND=JPIM) :: ISEND, ITAG, JBLK, JFLD, JK, JL, IFLD, II, IFLDS, INS, INR INTEGER(KIND=JPIM) :: JJ,JI,IFLDT, J +INTEGER(KIND=JPIA) :: JFLD64 + INTEGER(KIND=JPIM) :: IUVLEVS(KF_GP),IUVPARS(KF_GP),IGP2PARS(KF_GP) INTEGER(KIND=JPIM) :: IGP3APARS(KF_GP),IGP3ALEVS(KF_GP),IGP3BPARS(KF_GP),IGP3BLEVS(KF_GP) INTEGER(KIND=JPIM) :: IUVPAR,IUVLEV,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF @@ -394,8 +498,6 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ITAG = MTAGGL IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',0,ZHOOK_HANDLE_BAR) -ALLOCATE(ZCOMBUFS(-1:KSENDCOUNT,KNSEND)) -ALLOCATE(ZCOMBUFR(-1:KRECVCOUNT,KNRECV)) CALL GSTATS_BARRIER(761) IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',1,ZHOOK_HANDLE_BAR) @@ -409,7 +511,7 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ! Receive loop......................................................... DO INR=1,KNRECV IRECV=KRECV(INR) - CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), & + CALL MPL_RECV(PCOMBUFR(-1:KRECVTOT(IRECV),INR), & & KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ_RECV(INR), & & KTAG=ITAG,CDSTRING='TRGTOL_COMM: NON-BLOCKING IRECV' ) @@ -626,44 +728,56 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ENDIF ENDDO CALL GSTATS(1601,0) -!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) +#ifdef __NEC__ +! Loops inversion is still better on Aurora machines, according to CHMI. REK. +!$OMP PARALLEL DO SCHEDULE(DYNAMIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) +#else +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) +#endif DO JBLK=1,NGPBLKS IFIRST = KGPTRSEND(1,JBLK,MYSETW) IF(IFIRST > 0) THEN ILAST = KGPTRSEND(2,JBLK,MYSETW) +! Address PGLAT over 64 bits because its size may exceed 2 GB for big data and +! small number of tasks. IF(LLPGPONLY) THEN - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) + DO JFLD64=1,IFLDS + IFLD = IFLDOFF(JFLD64) +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGP(JK,IFLD,JBLK) + PGLAT(JFLD64,KINDEX(IPOS)) = PGP(JK,IFLD,JBLK) ENDDO ENDDO ELSE - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) + DO JFLD64=1,IFLDS + IFLD = IFLDOFF(JFLD64) IF(LLUV(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) + PGLAT(JFLD64,KINDEX(IPOS)) = PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) ENDDO ELSEIF(LLGP2(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGP2(JK,IGP2PARS(IFLD),JBLK) + PGLAT(JFLD64,KINDEX(IPOS)) = PGP2(JK,IGP2PARS(IFLD),JBLK) ENDDO ELSEIF(LLGP3A(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK) + PGLAT(JFLD64,KINDEX(IPOS)) = PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK) ENDDO ELSEIF(LLGP3B(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK) + PGLAT(JFLD64,KINDEX(IPOS)) = PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK) ENDDO ELSE - WRITE(NOUT,*)'TRGTOL_MOD: ERROR',JFLD,IFLD + WRITE(NOUT,*)'TRGTOL_MOD: ERROR',JFLD64,IFLD CALL ABORT_TRANS('TRGTOL_MOD: ERROR') ENDIF ENDDO @@ -712,8 +826,8 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ENDIF ENDDO - ZCOMBUFS(-1,INS) = 1 - ZCOMBUFS(0,INS) = IFLD + PCOMBUFS(-1,INS) = 1 + PCOMBUFS(0,INS) = IFLD ENDDO !$OMP END PARALLEL DO @@ -722,8 +836,8 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ISEND=KSEND(INS) IPOS=IPOSPLUS(INS) - ISEND_FLD_START=ZCOMBUFS(-1,INS) - ISEND_FLD_END = ZCOMBUFS(0,INS) + ISEND_FLD_START=PCOMBUFS(-1,INS) + ISEND_FLD_END = PCOMBUFS(0,INS) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(IFLDT,JBLK,IFIRST,ILAST,JK,JJ,JI) DO JJ=ISEND_FLD_START,ISEND_FLD_END @@ -735,33 +849,33 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& IF(LLINDER) THEN DO JK=IFIRST,ILAST JI=(JJ-ISEND_FLD_START)*IPOS+IJPOS(JBLK,INS)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP(JK,KPTRGP(IFLDT),JBLK) + PCOMBUFS(JI,INS) = PGP(JK,KPTRGP(IFLDT),JBLK) ENDDO ELSE IF(LLPGPONLY) THEN DO JK=IFIRST,ILAST JI=(JJ-ISEND_FLD_START)*IPOS+IJPOS(JBLK,INS)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP(JK,IFLDT,JBLK) + PCOMBUFS(JI,INS) = PGP(JK,IFLDT,JBLK) ENDDO ELSEIF(LLUV(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-ISEND_FLD_START)*IPOS+IJPOS(JBLK,INS)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) + PCOMBUFS(JI,INS) = PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) ENDDO ELSEIF(LLGP2(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-ISEND_FLD_START)*IPOS+IJPOS(JBLK,INS)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP2(JK,IGP2PARS(IFLDT),JBLK) + PCOMBUFS(JI,INS) = PGP2(JK,IGP2PARS(IFLDT),JBLK) ENDDO ELSEIF(LLGP3A(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-ISEND_FLD_START)*IPOS+IJPOS(JBLK,INS)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) + PCOMBUFS(JI,INS) = PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) ENDDO ELSEIF(LLGP3B(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-ISEND_FLD_START)*IPOS+IJPOS(JBLK,INS)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) + PCOMBUFS(JI,INS) = PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) ENDDO ENDIF ENDIF @@ -771,11 +885,11 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& !$OMP END PARALLEL DO IF (NTRANS_SYNC_LEVEL <= 1) THEN - CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND), & + CALL MPL_SEND(PCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ_SEND(INS), & & KTAG=ITAG,CDSTRING='TRGTOL_COMM: NON-BLOCKING ISEND' ) ELSE - CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND), & + CALL MPL_SEND(PCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_BLOCKING_BUFFERED, & & KTAG=ITAG,CDSTRING='TRGTOL_COMM: BLOCKING BUFFERED BSEND' ) ENDIF @@ -792,7 +906,7 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ELSE INR = JNR IRECV=KRECV(INR) - CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), & + CALL MPL_RECV(PCOMBUFR(-1:KRECVTOT(IRECV),INR), & & KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_BLOCKING_STANDARD, & & KTAG=ITAG,CDSTRING='TRGTOL_COMM: BLOCKING RECV' ) @@ -800,13 +914,13 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& IRECV=KRECV(INR) ILEN = KRECVTOT(IRECV)/KF_FS - IRECV_FLD_START = ZCOMBUFR(-1,INR) - IRECV_FLD_END = ZCOMBUFR(0,INR) + IRECV_FLD_START = PCOMBUFR(-1,INR) + IRECV_FLD_END = PCOMBUFR(0,INR) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JL,II,JFLD) DO JL=1,ILEN II = KINDEX(KNDOFF(IRECV)+JL) DO JFLD=IRECV_FLD_START,IRECV_FLD_END - PGLAT(JFLD,II) = ZCOMBUFR(JL+(JFLD-IRECV_FLD_START)*ILEN,INR) + PGLAT(JFLD,II) = PCOMBUFR(JL+(JFLD-IRECV_FLD_START)*ILEN,INR) ENDDO ENDDO !$OMP END PARALLEL DO @@ -829,8 +943,6 @@ SUBROUTINE TRGTOL_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& CALL GSTATS(804,1) ENDIF -DEALLOCATE(ZCOMBUFR) -DEALLOCATE(ZCOMBUFS) CALL GSTATS_BARRIER2(761) END SUBROUTINE TRGTOL_COMM diff --git a/src/trans/internal/trltog_mod.F90 b/src/trans/internal/trltog_mod.F90 index d7731e327..49e675e01 100644 --- a/src/trans/internal/trltog_mod.F90 +++ b/src/trans/internal/trltog_mod.F90 @@ -11,7 +11,7 @@ MODULE TRLTOG_MOD PUBLIC TRLTOG -PRIVATE TRLTOG_PROLOG, TRLTOG_COMM +PRIVATE TRLTOG_PROLOG, TRLTOG_COMM, TRLTOG_COMM_HEAP, TRLTOG_COMM_STACK CONTAINS @@ -54,11 +54,13 @@ SUBROUTINE TRLTOG(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& ! Modifications. ! -------------- ! Original : 18-Aug-2014 from trltog +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC USE TPM_TRANS ,ONLY : NGPBLKS @@ -97,10 +99,17 @@ SUBROUTINE TRLTOG(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& CALL TRLTOG_PROLOG(KF_FS,KF_GP,KVSET,& & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, & & ISETAL,ISETBL,ISETWL,ISETVL) -CALL TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, & - & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, & - & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2,& - & ISETAL,ISETBL,ISETWL,ISETVL) +IF (NSTACK_MEMORY_TR==0) THEN + CALL TRLTOG_COMM_HEAP(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, & + & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2,& + & ISETAL,ISETBL,ISETWL,ISETVL) +ELSE + CALL TRLTOG_COMM_STACK(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, & + & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2,& + & ISETAL,ISETBL,ISETWL,ISETVL) +ENDIF IF (LHOOK) CALL DR_HOOK('TRLTOG',1,ZHOOK_HANDLE) @@ -270,8 +279,114 @@ SUBROUTINE TRLTOG_PROLOG(KF_FS,KF_GP,KVSET,& END SUBROUTINE TRLTOG_PROLOG +SUBROUTINE TRLTOG_COMM_HEAP(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, & + & KSETAL, KSETBL,KSETWL,KSETVL) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC +USE TPM_TRANS ,ONLY : NGPBLKS + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS,KF_GP +REAL(KIND=JPRB),INTENT(IN) :: PGLAT(KF_FS,D%NLENGTF) +INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP) +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KNSEND +INTEGER(KIND=JPIM), INTENT(IN) :: KNRECV +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSEND (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECV (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF) +INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETAL(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETBL(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETWL(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETVL(NPROC) + +REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFS(:,:) +REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFR(:,:) + +ALLOCATE(ZCOMBUFS(-1:KSENDCOUNT,KNSEND)) +! Now, force the OS to allocate this shared array right now, not when it starts to be used which is +! an OPEN-MP loop, that would cause a threads synchronization lock : +IF (KNSEND > 0 .AND. KSENDCOUNT >=-1) ZCOMBUFS(-1,1)=HUGE(1._JPRB) +ALLOCATE(ZCOMBUFR(-1:KRECVCOUNT,KNRECV)) + +CALL TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & ZCOMBUFS,ZCOMBUFR, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, & + & KSETAL, KSETBL,KSETWL,KSETVL) + +DEALLOCATE(ZCOMBUFR) +DEALLOCATE(ZCOMBUFS) + +END SUBROUTINE TRLTOG_COMM_HEAP + +SUBROUTINE TRLTOG_COMM_STACK(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, & + & KSETAL, KSETBL,KSETWL,KSETVL) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC +USE TPM_TRANS ,ONLY : NGPBLKS + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS,KF_GP +REAL(KIND=JPRB),INTENT(IN) :: PGLAT(KF_FS,D%NLENGTF) +INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP) +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVCOUNT +INTEGER(KIND=JPIM), INTENT(IN) :: KNSEND +INTEGER(KIND=JPIM), INTENT(IN) :: KNRECV +INTEGER(KIND=JPIM), INTENT(IN) :: KSENDTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECVTOT (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSEND (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KRECV (NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF) +INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETAL(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETBL(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETWL(NPROC) +INTEGER(KIND=JPIM), INTENT(IN) :: KSETVL(NPROC) + +REAL(KIND=JPRB) :: ZCOMBUFS(-1:KSENDCOUNT,KNSEND) +REAL(KIND=JPRB) :: ZCOMBUFR(-1:KRECVCOUNT,KNRECV) + +CALL TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& + & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & ZCOMBUFS,ZCOMBUFR, & + & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, & + & KSETAL, KSETBL,KSETWL,KSETVL) + +END SUBROUTINE TRLTOG_COMM_STACK + SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,& + & PCOMBUFS,PCOMBUFR, & & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, & & KSETAL, KSETBL,KSETWL,KSETVL) @@ -319,7 +434,7 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ! to differ from NPRGPEW ! =99-03-29= Mats Hamrud and Deborah Salmond ! JUMP in FFT's changed to 1 -! KINDEX introduced and ZCOMBUF not used for same PE +! KINDEX introduced and PCOMBUF not used for same PE ! 01-11-23 Deborah Salmond and John Hague ! LIMP_NOOLAP Option for non-overlapping message passing ! and buffer packing @@ -328,9 +443,10 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ! 03-0-02 G. Radnoti: Call barrier always when nproc>1 ! 08-01-01 G.Mozdzynski: cleanup ! 09-01-02 G.Mozdzynski: use non-blocking recv and send +! R. El Khatib 09-Sep-2020 64 bits addressing for PGLAT ! ------------------------------------------------------------------ -USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPIA USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY, & @@ -362,6 +478,8 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF) INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC) INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS) +REAL(KIND=JPRB), INTENT(INOUT) :: PCOMBUFS(-1:KSENDCOUNT,KNSEND) +REAL(KIND=JPRB), INTENT(INOUT) :: PCOMBUFR(-1:KRECVCOUNT,KNRECV) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) @@ -375,9 +493,6 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ! LOCAL VARIABLES -REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFS(:,:) -REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUFR(:,:) - INTEGER(KIND=JPIM) :: IPOSPLUS(KNRECV) INTEGER(KIND=JPIM) :: ISETW(KNRECV) INTEGER(KIND=JPIM) :: JPOS(NGPBLKS,KNRECV) @@ -389,6 +504,8 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& INTEGER(KIND=JPIM) :: ISEND, ITAG, JBLK, JFLD, JK, JL, IFLDS, IPROC,JROC, INR, INS INTEGER(KIND=JPIM) :: II,ILEN,IBUFLENS,IBUFLENR, IFLDT, JI, JJ, J +INTEGER(KIND=JPIA) :: JFLD64 + LOGICAL :: LLPGPUV,LLPGP3A,LLPGP3B,LLPGP2,LLPGPONLY LOGICAL :: LLUV(KF_GP),LLGP2(KF_GP),LLGP3A(KF_GP),LLGP3B(KF_GP) LOGICAL :: LLINDER @@ -412,8 +529,6 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ITAG = MTAGLG IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',0,ZHOOK_HANDLE_BAR) -ALLOCATE(ZCOMBUFS(-1:KSENDCOUNT,KNSEND)) -ALLOCATE(ZCOMBUFR(-1:KRECVCOUNT,KNRECV)) CALL GSTATS_BARRIER(762) IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',1,ZHOOK_HANDLE_BAR) @@ -423,7 +538,7 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& !...Receive loop......................................................... DO INR=1,KNRECV IRECV=KRECV(INR) - CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), & + CALL MPL_RECV(PCOMBUFR(-1:KRECVTOT(IRECV),INR), & & KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ_RECV(INR), & & KTAG=ITAG,CDSTRING='TRLTOG_COMM: NON-BLOCKING IRECV' ) @@ -634,44 +749,56 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ENDDO CALL GSTATS(1604,0) -!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) +#ifdef __NEC__ +! Loops inversion is still better on Aurora machines, according to CHMI. REK. +!$OMP PARALLEL DO SCHEDULE(DYNAMIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) +#else +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) +#endif DO JBLK=1,NGPBLKS IFIRST = KGPTRSEND(1,JBLK,MYSETW) IF(IFIRST > 0) THEN ILAST = KGPTRSEND(2,JBLK,MYSETW) +! Address PGLAT over 64 bits because its size may exceed 2 GB for big data and +! small number of tasks. IF(LLPGPONLY) THEN - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) + DO JFLD64=1,IFLDS + IFLD = IFLDOFF(JFLD64) +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP(JK,IFLD,JBLK) = PGLAT(JFLD,KINDEX(IPOS)) + PGP(JK,IFLD,JBLK) = PGLAT(JFLD64,KINDEX(IPOS)) ENDDO ENDDO ELSE - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) + DO JFLD64=1,IFLDS + IFLD = IFLDOFF(JFLD64) IF(LLUV(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) = PGLAT(JFLD,KINDEX(IPOS)) + PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) = PGLAT(JFLD64,KINDEX(IPOS)) ENDDO ELSEIF(LLGP2(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP2(JK,IGP2PARS(IFLD),JBLK)=PGLAT(JFLD,KINDEX(IPOS)) + PGP2(JK,IGP2PARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS)) ENDDO ELSEIF(LLGP3A(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK)=PGLAT(JFLD,KINDEX(IPOS)) + PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS)) ENDDO ELSEIF(LLGP3B(IFLD)) THEN +!DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK)=PGLAT(JFLD,KINDEX(IPOS)) + PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS)) ENDDO ELSE - WRITE(NOUT,*)'TRLTOG_MOD: ERROR',JFLD,IFLD + WRITE(NOUT,*)'TRLTOG_MOD: ERROR',JFLD64,IFLD CALL ABORT_TRANS('TRLTOG_MOD: ERROR') ENDIF ENDDO @@ -703,18 +830,18 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& DO JL=1,ILEN II = KINDEX(KNDOFF(ISEND)+JL) DO JFLD=ISEND_FLD_START,ISEND_FLD_END - ZCOMBUFS((JFLD-ISEND_FLD_START)*ILEN+JL,INS) = PGLAT(JFLD,II) + PCOMBUFS((JFLD-ISEND_FLD_START)*ILEN+JL,INS) = PGLAT(JFLD,II) ENDDO ENDDO !$OMP END PARALLEL DO - ZCOMBUFS(-1,INS) = 1 - ZCOMBUFS(0,INS) = KF_FS + PCOMBUFS(-1,INS) = 1 + PCOMBUFS(0,INS) = KF_FS IF (NTRANS_SYNC_LEVEL <= 1) THEN - CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND),& + CALL MPL_SEND(PCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND),& & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ_SEND(INS), & & KTAG=ITAG,CDSTRING='TRLTOG_COMM: NON-BLOCKING ISEND') ELSE - CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND),& + CALL MPL_SEND(PCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND),& & KMP_TYPE=JP_BLOCKING_BUFFERED, & & KTAG=ITAG,CDSTRING='TRLTOG_COMM: BLOCKING BUFFERED BSEND') ENDIF @@ -759,15 +886,15 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& ELSE INR = JNR IRECV=KRECV(INR) - CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), & + CALL MPL_RECV(PCOMBUFR(-1:KRECVTOT(IRECV),INR), & & KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_BLOCKING_STANDARD, & & KTAG=ITAG,CDSTRING='TRLTOG_COMM: BLOCKING RECV' ) ENDIF IPOS=IPOSPLUS(INR) - IRECV_FLD_START = ZCOMBUFR(-1,INR) - IRECV_FLD_END = ZCOMBUFR(0,INR) + IRECV_FLD_START = PCOMBUFR(-1,INR) + IRECV_FLD_END = PCOMBUFR(0,INR) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(IFLDT,IFIRST,ILAST,JK,JJ,JI,JBLK) DO JJ=IRECV_FLD_START,IRECV_FLD_END @@ -779,32 +906,32 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& IF(LLINDER) THEN DO JK=IFIRST,ILAST JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1 - PGP(JK,KPTRGP(IFLDT),JBLK) = ZCOMBUFR(JI,INR) + PGP(JK,KPTRGP(IFLDT),JBLK) = PCOMBUFR(JI,INR) ENDDO ELSEIF(LLPGPONLY) THEN DO JK=IFIRST,ILAST JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1 - PGP(JK,IFLDT,JBLK) = ZCOMBUFR(JI,INR) + PGP(JK,IFLDT,JBLK) = PCOMBUFR(JI,INR) ENDDO ELSEIF(LLUV(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1 - PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) + PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) = PCOMBUFR(JI,INR) ENDDO ELSEIF(LLGP2(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1 - PGP2(JK,IGP2PARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) + PGP2(JK,IGP2PARS(IFLDT),JBLK) = PCOMBUFR(JI,INR) ENDDO ELSEIF(LLGP3A(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1 - PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) + PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) = PCOMBUFR(JI,INR) ENDDO ELSEIF(LLGP3B(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1 - PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) + PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) = PCOMBUFR(JI,INR) ENDDO ENDIF ENDIF @@ -825,8 +952,6 @@ SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,& CALL GSTATS(805,1) -DEALLOCATE(ZCOMBUFR) -DEALLOCATE(ZCOMBUFS) CALL GSTATS_BARRIER2(762) END SUBROUTINE TRLTOG_COMM From c832bff81ef82c403593c20ec0a89a0c2fc2e6ba Mon Sep 17 00:00:00 2001 From: EL KHATIB Ryad Date: Mon, 13 Nov 2023 11:24:09 +0000 Subject: [PATCH 02/12] Variable LALL_FFTW to perform fftw transforms in one bunch of all fields --- src/trans/external/setup_trans.F90 | 10 +++++++++- src/trans/include/ectrans/setup_trans.h | 4 +++- src/trans/internal/ftdir_mod.F90 | 5 ++--- src/trans/internal/ftdirad_mod.F90 | 5 ++--- src/trans/internal/ftinv_mod.F90 | 4 ++-- src/trans/internal/ftinvad_mod.F90 | 5 ++--- src/trans/internal/tpm_fftw.F90 | 10 ++++++---- 7 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/trans/external/setup_trans.F90 b/src/trans/external/setup_trans.F90 index 416db52b0..40e0689c3 100644 --- a/src/trans/external/setup_trans.F90 +++ b/src/trans/external/setup_trans.F90 @@ -10,7 +10,7 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& &KTMAX,KRESOL,PWEIGHT,LDGRIDONLY,LDUSERPNM,LDKEEPRPNM,LDUSEFLT,& -&LDSPSETUPONLY,LDPNMONLY,LDUSEFFTW,& +&LDSPSETUPONLY,LDPNMONLY,LDUSEFFTW,LD_ALL_FFTW,& &LDLL,LDSHIFTLL,CDIO_LEGPOL,CDLEGPOLFNAME,KLEGPOLPTR,KLEGPOLPTR_LEN) !**** *SETUP_TRANS* - Setup transform package for specific resolution @@ -52,6 +52,8 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& ! FLT, otherwise always kept) ! LDPNMONLY - Compute the Legendre polynomials only, not the FFTs. ! LDUSEFFTW - Use FFTW for FFTs +! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another + ! LDLL - Setup second set of input/output latitudes ! the number of input/output latitudes to transform is equal KDGL ! or KDGL+2 in the case that includes poles + equator @@ -94,6 +96,7 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& ! G. Mozdzynski : Jun 2015 Support alternative FFTs to FFTW ! M.Hamrud/W.Deconinck : July 2015 IO options for Legenndre polynomials ! R. El Khatib 07-Mar-2016 Better flexibility for Legendre polynomials computation in stretched mode +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD @@ -141,6 +144,7 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSTRET LOGICAL ,OPTIONAL,INTENT(IN):: LDGRIDONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFLT +LOGICAL ,OPTIONAL,INTENT(IN):: LD_ALL_FFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDUSERPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDKEEPRPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDSPSETUPONLY @@ -228,6 +232,7 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& S%LUSEFLT=.FALSE. ! Use fast legendre transforms #ifdef WITH_FFTW TW%LFFTW=.FALSE. ! Use FFTW interface for FFTs +TW%LALL_FFTW=.FALSE. ! transform fields one at a time #endif LLSPSETUPONLY = .FALSE. ! Only create distributed spectral setup S%LDLL = .FALSE. ! use mapping to/from second set of latitudes @@ -341,6 +346,9 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& IF( LLSPSETUPONLY .OR. D%LGRIDONLY ) THEN TW%LFFTW = .FALSE. ENDIF +IF(PRESENT(LD_ALL_FFTW)) THEN + TW%LALL_FFTW=LD_ALL_FFTW +ENDIF #endif S%LSOUTHPNM=.FALSE. diff --git a/src/trans/include/ectrans/setup_trans.h b/src/trans/include/ectrans/setup_trans.h index 810e765b0..9548700fa 100644 --- a/src/trans/include/ectrans/setup_trans.h +++ b/src/trans/include/ectrans/setup_trans.h @@ -11,7 +11,7 @@ INTERFACE SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& &KTMAX,KRESOL,PWEIGHT,LDGRIDONLY,LDUSERPNM,LDKEEPRPNM,LDUSEFLT,& -&LDSPSETUPONLY,LDPNMONLY,LDUSEFFTW,& +&LDSPSETUPONLY,LDPNMONLY,LDUSEFFTW,LD_ALL_FFTW,& &LDLL,LDSHIFTLL,CDIO_LEGPOL,CDLEGPOLFNAME,KLEGPOLPTR,KLEGPOLPTR_LEN) !**** *SETUP_TRANS* - Setup transform package for specific resolution @@ -51,6 +51,7 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& ! FLT, otherwise always kept) ! LDPNMONLY - Compute the Legendre polynomialsonly, not the FFTs. ! LDUSEFFTW - Use FFTW for FFTs +! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another ! LDLL - Setup second set of input/output latitudes ! the number of input/output latitudes to transform is equal KDGL ! or KDGL+2 in the case that includes poles + equator @@ -96,6 +97,7 @@ REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSTRET LOGICAL ,OPTIONAL,INTENT(IN):: LDGRIDONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFLT +LOGICAL ,OPTIONAL,INTENT(IN):: LD_ALL_FFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDUSERPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDKEEPRPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDPNMONLY diff --git a/src/trans/internal/ftdir_mod.F90 b/src/trans/internal/ftdir_mod.F90 index 8c8ad6acc..d9aa32048 100644 --- a/src/trans/internal/ftdir_mod.F90 +++ b/src/trans/internal/ftdir_mod.F90 @@ -43,7 +43,7 @@ SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW - +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPIB, JPRB @@ -65,7 +65,6 @@ SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,IST1 INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN, ITYPE -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time ! ------------------------------------------------------------------ @@ -103,7 +102,7 @@ SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) #ifdef WITH_FFTW ELSE - CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,LL_ALL,PREEL) + CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) ENDIF #endif diff --git a/src/trans/internal/ftdirad_mod.F90 b/src/trans/internal/ftdirad_mod.F90 index a2dcdc41a..358615336 100644 --- a/src/trans/internal/ftdirad_mod.F90 +++ b/src/trans/internal/ftdirad_mod.F90 @@ -42,7 +42,7 @@ SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW - +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB @@ -64,7 +64,6 @@ SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE REAL(KIND=JPRB) :: ZMUL -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time ! ------------------------------------------------------------------ ITYPE = 1 @@ -101,7 +100,7 @@ SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) #ifdef WITH_FFTW ELSE - CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,LL_ALL,PREEL) + CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) ENDIF #endif diff --git a/src/trans/internal/ftinv_mod.F90 b/src/trans/internal/ftinv_mod.F90 index bb08da7fd..36d2a3e4c 100644 --- a/src/trans/internal/ftinv_mod.F90 +++ b/src/trans/internal/ftinv_mod.F90 @@ -42,6 +42,7 @@ SUBROUTINE FTINV(PREEL,KFIELDS,KGL) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB @@ -62,7 +63,6 @@ SUBROUTINE FTINV(PREEL,KFIELDS,KGL) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,IST1 INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN, ITYPE -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time ! ------------------------------------------------------------------ @@ -103,7 +103,7 @@ SUBROUTINE FTINV(PREEL,KFIELDS,KGL) #ifdef WITH_FFTW ELSE - CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,LL_ALL,PREEL) + CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) ENDIF #endif diff --git a/src/trans/internal/ftinvad_mod.F90 b/src/trans/internal/ftinvad_mod.F90 index 08adb50e8..d95b8c09e 100644 --- a/src/trans/internal/ftinvad_mod.F90 +++ b/src/trans/internal/ftinvad_mod.F90 @@ -42,7 +42,7 @@ SUBROUTINE FTINVAD(PREEL,KFIELDS,KGL) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW - +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPIB, JPRB @@ -65,7 +65,6 @@ SUBROUTINE FTINVAD(PREEL,KFIELDS,KGL) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time ! ------------------------------------------------------------------ @@ -109,7 +108,7 @@ SUBROUTINE FTINVAD(PREEL,KFIELDS,KGL) #ifdef WITH_FFTW ELSE - CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,LL_ALL,PREEL) + CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) ENDIF #endif diff --git a/src/trans/internal/tpm_fftw.F90 b/src/trans/internal/tpm_fftw.F90 index 6386688ae..c98220945 100644 --- a/src/trans/internal/tpm_fftw.F90 +++ b/src/trans/internal/tpm_fftw.F90 @@ -17,6 +17,7 @@ MODULE TPM_FFTW ! -------------- ! Original October 2014 ! R. El Khatib 01-Sep-2015 More subroutines for better modularity +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility USE, INTRINSIC :: ISO_C_BINDING @@ -46,6 +47,7 @@ MODULE TPM_FFTW INTEGER(KIND=JPIM) :: N_MAX=0 ! maximum number of latitudes INTEGER(KIND=JPIM) :: N_MAX_PLANS=4 ! maximum number of plans for each active latitude LOGICAL :: LFFTW=.FALSE. + LOGICAL :: LALL_FFTW=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time END TYPE FFTW_TYPE @@ -422,8 +424,8 @@ SUBROUTINE EXEC_EFFTW(KTYPE,KRLEN,KCLEN,KOFF,KFIELDS,LD_ALL,PREEL) CALL SFFTW_EXECUTE_DFT_C2R(IPLAN_C2R,ZFFT,ZFFT) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',1,ZHOOK_HANDLE2) - DO JJ=1,KRLEN - DO JF=1,KFIELDS + DO JF=1,KFIELDS + DO JJ=1,KRLEN PREEL(KOFF+JJ-1,JF)=ZFFT(JJ,JF) ENDDO ENDDO @@ -440,8 +442,8 @@ SUBROUTINE EXEC_EFFTW(KTYPE,KRLEN,KCLEN,KOFF,KFIELDS,LD_ALL,PREEL) CALL SFFTW_EXECUTE_DFT_R2C(IPLAN_C2R,ZFFT,ZFFT) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',1,ZHOOK_HANDLE2) - DO JJ=1,KCLEN - DO JF=1,KFIELDS + DO JF=1,KFIELDS + DO JJ=1,KCLEN PREEL(KOFF+JJ-1,JF)=ZFFT(JJ,JF)/REAL(KRLEN,JPRB) ENDDO ENDDO From d2f80d7adec4a1123af7752f4198dba13dec1814 Mon Sep 17 00:00:00 2001 From: MARY Alexandre Date: Mon, 8 Apr 2024 17:36:35 +0000 Subject: [PATCH 03/12] phase with CY49R1 --- src/trans/external/ini_spec_dist.F90 | 11 +++-- src/trans/include/ectrans/get_current.h | 2 +- src/trans/include/ectrans/ini_spec_dist.h | 9 +++- src/trans/internal/dist_grid_ctl_mod.F90 | 52 ++++++++++---------- src/trans/internal/sutrle_mod.F90 | 59 +++++++++++------------ src/trans/internal/suwavedi_mod.F90 | 3 ++ 6 files changed, 73 insertions(+), 63 deletions(-) diff --git a/src/trans/external/ini_spec_dist.F90 b/src/trans/external/ini_spec_dist.F90 index 8260a508d..cc8f2cab6 100644 --- a/src/trans/external/ini_spec_dist.F90 +++ b/src/trans/external/ini_spec_dist.F90 @@ -9,7 +9,7 @@ ! SUBROUTINE INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& - &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS) + &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS,KPTRMS,KALLMS) !**** *INI_SPEC_DIST* - Initialize spectral wave distribution @@ -37,6 +37,9 @@ SUBROUTINE INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& ! KSPEC2MX - Maximum KSPEC2 across PEs (output) ! KPOSSP - Global spectral fields partitioning (output) ! KMYMS - This PEs spectral zonal wavenumbers (output) +! KPTRMS - Pointer to the first wave number of a given a-set (output) +! KALLMS - Wave numbers for all wave-set concatenated together +! to give all wave numbers in wave-set order (output) ! Implicit arguments : NONE ! -------------------- @@ -70,8 +73,10 @@ SUBROUTINE INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KASM0(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPROCM(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KUMPP(KPRTRW) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMYMS(KSMAX+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPOSSP(KPRTRW+1) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMYMS(KSMAX+1) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPTRMS(KPRTRW) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KALLMS(KSMAX+1) !ifndef INTERFACE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -81,7 +86,7 @@ SUBROUTINE INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& IF (LHOOK) CALL DR_HOOK('INI_SPEC_DIST',0,ZHOOK_HANDLE) CALL SUWAVEDI(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& - &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS) + &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS,KPTRMS,KALLMS) IF (LHOOK) CALL DR_HOOK('INI_SPEC_DIST',1,ZHOOK_HANDLE) diff --git a/src/trans/include/ectrans/get_current.h b/src/trans/include/ectrans/get_current.h index 882f9ee82..4ae86992e 100644 --- a/src/trans/include/ectrans/get_current.h +++ b/src/trans/include/ectrans/get_current.h @@ -1,4 +1,4 @@ -! (C) Copyright 2000- Meteo France. +! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! This software is licensed under the terms of the Apache Licence Version 2.0 diff --git a/src/trans/include/ectrans/ini_spec_dist.h b/src/trans/include/ectrans/ini_spec_dist.h index 5b613950b..2abca9ff8 100644 --- a/src/trans/include/ectrans/ini_spec_dist.h +++ b/src/trans/include/ectrans/ini_spec_dist.h @@ -10,7 +10,7 @@ INTERFACE SUBROUTINE INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& - &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS) + &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS,KPTRMS,KALLMS) !**** *INI_SPEC_DIST* - Initialize spectral wave distribution @@ -38,6 +38,9 @@ SUBROUTINE INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& ! KSPEC2MX - Maximum KSPEC2 across PEs (output) ! KPOSSP - Global spectral fields partitioning (output) ! KMYMS - This PEs spectral zonal wavenumbers (output) +! KPTRMS - Pointer to the first wave number of a given a-set (output) +! KALLMS - Wave numbers for all wave-set concatenated together +! to give all wave numbers in wave-set order (output) ! Implicit arguments : NONE ! -------------------- @@ -66,7 +69,9 @@ INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPOLEGL INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KASM0(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPROCM(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KUMPP(KPRTRW) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMYMS(KSMAX+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPOSSP(KPRTRW+1) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMYMS(KSMAX+1) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPTRMS(KPRTRW) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KALLMS(KSMAX+1) END SUBROUTINE INI_SPEC_DIST END INTERFACE diff --git a/src/trans/internal/dist_grid_ctl_mod.F90 b/src/trans/internal/dist_grid_ctl_mod.F90 index 32207c2ee..349881d05 100644 --- a/src/trans/internal/dist_grid_ctl_mod.F90 +++ b/src/trans/internal/dist_grid_ctl_mod.F90 @@ -78,7 +78,7 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT) INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF,ILENR INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC -INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG) +INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG), IRECVREQ(KFDISTG) INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD INTEGER(KIND=JPIM), POINTER :: ISORT (:) LOGICAL :: LLSAME @@ -176,6 +176,24 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT) ! Message passing CALL GSTATS_BARRIER(791) CALL GSTATS(811,0) + ! Receive + + ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG)) + + IF( LLSAME )THEN + IRCV = KFROM(1) + ITAG = MTAGDISTGP + CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& + &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:') + ELSE + DO JFLD=1,KFDISTG + IRCV = KFROM(JFLD) + ITAG = MTAGDISTGP+JFLD + CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& + &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:') + ENDDO + ENDIF + ! Send IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN @@ -200,44 +218,24 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT) ENDIF ENDDO ENDIF - - ! Receive - - ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG)) - - IF( LLSAME )THEN - IRCV = KFROM(1) - ITAG = MTAGDISTGP - CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& - &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_CTL:') - IF( ILENR /= D%NGPTOTMX*KFDISTG )THEN - CALL ABORT_TRANS(' DIST_GRID_CTL: INVALID RECEIVE MESSAGE LENGTH 1') - ENDIF - ELSE - DO JFLD=1,KFDISTG - IRCV = KFROM(JFLD) - ITAG = MTAGDISTGP+JFLD - CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& - &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_CTL:') - IF( ILENR /= D%NGPTOT )THEN - CALL ABORT_TRANS(' DIST_GRID_CTL: INVALID RECEIVE MESSAGE LENGTH 2') - ENDIF - ENDDO - ENDIF -! Wait for send to complete +! Wait for sends and receives to complete IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), & & CDSTRING='DIST_GRID_CTL: WAIT 1') ENDIF + CALL MPL_WAIT(KREQUEST=IRECVREQ(1), & + & CDSTRING='DIST_GRID_CTL: WAIT 2') ELSE DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,JFLD), & - & CDSTRING='DIST_GRID_CTL: WAIT 2') + & CDSTRING='DIST_GRID_CTL: WAIT 3') ENDIF + CALL MPL_WAIT(KREQUEST=IRECVREQ(JFLD), & + & CDSTRING='DIST_GRID_CTL: WAIT 4') ENDDO ENDIF CALL GSTATS(811,1) diff --git a/src/trans/internal/sutrle_mod.F90 b/src/trans/internal/sutrle_mod.F90 index 96d083cb7..ece0e7aaf 100644 --- a/src/trans/internal/sutrle_mod.F90 +++ b/src/trans/internal/sutrle_mod.F90 @@ -128,6 +128,20 @@ SUBROUTINE SUTRLE(PNM,KGL,KLOOP) CALL GSTATS(1141,1) ENDIF +IRREQ=0 +DO JROC=1,NPRTRV-1 + IRECV = MYSETV+JROC + IF (IRECV > NPRTRV) IRECV = IRECV-NPRTRV + IRECVSET = IRECV + CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET) + IRREQ = IRREQ+1 + CALL GSTATS(801,0) + CALL MPL_RECV(ZRCVBUFV(:,IRECVSET),KSOURCE=NPRCIDS(IRECV), & + &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& + & KTAG=ITAG,CDSTRING='SUTRLE:') + CALL GSTATS(801,1) +ENDDO + ISREQ = 0 DO JROC=1,NPRTRV-1 ISEND = MYSETV-JROC @@ -143,20 +157,6 @@ SUBROUTINE SUTRLE(PNM,KGL,KLOOP) ENDDO -IRREQ=0 -DO JROC=1,NPRTRV-1 - IRECV = MYSETV+JROC - IF (IRECV > NPRTRV) IRECV = IRECV-NPRTRV - IRECVSET = IRECV - CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET) - IRREQ = IRREQ+1 - CALL GSTATS(801,0) - CALL MPL_RECV(ZRCVBUFV(:,IRECVSET),KSOURCE=NPRCIDS(IRECV), & - &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& - & KTAG=ITAG,CDSTRING='SUTRLE:') - CALL GSTATS(801,1) -ENDDO - IF(ISREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), & @@ -276,22 +276,6 @@ SUBROUTINE SUTRLE(PNM,KGL,KLOOP) !$OMP END PARALLEL DO CALL GSTATS(1141,1) -ISREQ = 0 -DO JROC=1,NPRTRW-1 - ISEND = MYSETW-JROC - IF (ISEND <= 0) ISEND = ISEND+NPRTRW - ISENDSET = ISEND - CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) - ISENDSIZE = IPOSW(ISENDSET) - ISREQ = ISREQ+1 - CALL GSTATS(801,0) - CALL MPL_SEND(ZSNDBUFW(1:ISENDSIZE,ISENDSET),KDEST=NPRCIDS(ISEND), & - & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& - & KTAG=ITAG,CDSTRING='SUTRLE:') - CALL GSTATS(801,1) -ENDDO - - IRREQ = 0 DO JROC=1,NPRTRW-1 @@ -309,6 +293,21 @@ SUBROUTINE SUTRLE(PNM,KGL,KLOOP) CALL GSTATS(801,1) ENDDO +ISREQ = 0 +DO JROC=1,NPRTRW-1 + ISEND = MYSETW-JROC + IF (ISEND <= 0) ISEND = ISEND+NPRTRW + ISENDSET = ISEND + CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) + ISENDSIZE = IPOSW(ISENDSET) + ISREQ = ISREQ+1 + CALL GSTATS(801,0) + CALL MPL_SEND(ZSNDBUFW(1:ISENDSIZE,ISENDSET),KDEST=NPRCIDS(ISEND), & + & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& + & KTAG=ITAG,CDSTRING='SUTRLE:') + CALL GSTATS(801,1) +ENDDO + IF(ISREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), & diff --git a/src/trans/internal/suwavedi_mod.F90 b/src/trans/internal/suwavedi_mod.F90 index 2e85b8af9..bad28d10b 100644 --- a/src/trans/internal/suwavedi_mod.F90 +++ b/src/trans/internal/suwavedi_mod.F90 @@ -39,6 +39,9 @@ SUBROUTINE SUWAVEDI(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& ! KSPEC2MX - Maximum KSPEC2 across PEs (output) ! KPOSSP - Global spectral fields partitioning (output) ! KMYMS - This PEs spectral zonal wavenumbers (output) +! KPTRMS - Pointer to the first wave number of a given a-set (output) +! KALLMS - Wave numbers for all wave-set concatenated together +! to give all wave numbers in wave-set order (output) ! Implicit arguments : NONE ! -------------------- From f33409f66760423b19c553aefcf00eca0f696d2e Mon Sep 17 00:00:00 2001 From: Daan Degrauwe Date: Thu, 30 May 2024 15:26:25 +0200 Subject: [PATCH 04/12] Added LAM transforms and LAM benchmark. --- CMakeLists.txt | 4 + src/CMakeLists.txt | 3 + src/etrans/CMakeLists.txt | 2 + src/etrans/biper/CMakeLists.txt | 44 + src/etrans/biper/external/etibihie.F90 | 101 ++ src/etrans/biper/external/fpbipere.F90 | 157 ++ src/etrans/biper/external/horiz_field.F90 | 66 + src/etrans/biper/include/etibihie.h | 22 + src/etrans/biper/include/fpbipere.h | 19 + src/etrans/biper/include/horiz_field.h | 13 + src/etrans/biper/internal/esmoothe_mod.F90 | 171 ++ src/etrans/biper/internal/espline_mod.F90 | 189 +++ src/etrans/biper/internal/ewindowe_mod.F90 | 162 ++ src/etrans/biper/internal/extper_mod.F90 | 144 ++ src/etrans/etrans/CMakeLists.txt | 54 + src/etrans/etrans/aux/ellips.F90 | 8 + src/etrans/etrans/aux/ellips.h | 91 + src/etrans/etrans/aux/ellips64.F90 | 8 + src/etrans/etrans/external/edir_trans.F90 | 500 ++++++ src/etrans/etrans/external/edir_transad.F90 | 493 ++++++ src/etrans/etrans/external/edist_grid.F90 | 136 ++ src/etrans/etrans/external/edist_spec.F90 | 195 +++ src/etrans/etrans/external/egath_grid.F90 | 129 ++ src/etrans/etrans/external/egath_spec.F90 | 203 +++ src/etrans/etrans/external/egpnorm_trans.F90 | 93 ++ src/etrans/etrans/external/einv_trans.F90 | 607 +++++++ src/etrans/etrans/external/einv_transad.F90 | 609 +++++++ src/etrans/etrans/external/esetup_trans.F90 | 308 ++++ src/etrans/etrans/external/especnorm.F90 | 136 ++ src/etrans/etrans/external/etrans_end.F90 | 147 ++ src/etrans/etrans/external/etrans_inq.F90 | 539 ++++++ src/etrans/etrans/external/etrans_release.F90 | 51 + src/etrans/etrans/include/edir_trans.h | 135 ++ src/etrans/etrans/include/edir_transad.h | 131 ++ src/etrans/etrans/include/edist_grid.h | 57 + src/etrans/etrans/include/edist_spec.h | 59 + src/etrans/etrans/include/egath_grid.h | 56 + src/etrans/etrans/include/egath_spec.h | 64 + src/etrans/etrans/include/egpnorm_trans.h | 59 + src/etrans/etrans/include/einv_trans.h | 151 ++ src/etrans/etrans/include/einv_transad.h | 150 ++ src/etrans/etrans/include/esetup_trans.h | 88 + src/etrans/etrans/include/especnorm.h | 56 + src/etrans/etrans/include/etrans_end.h | 41 + src/etrans/etrans/include/etrans_inq.h | 172 ++ src/etrans/etrans/include/etrans_release.h | 6 + src/etrans/etrans/internal/cpl_int_mod.F90 | 33 + src/etrans/etrans/internal/easre1ad_mod.F90 | 80 + src/etrans/etrans/internal/easre1b_mod.F90 | 93 ++ src/etrans/etrans/internal/easre1bad_mod.F90 | 97 ++ .../etrans/internal/edealloc_resol_mod.F90 | 102 ++ .../etrans/internal/edir_trans_ctl_mod.F90 | 202 +++ .../etrans/internal/edir_trans_ctlad_mod.F90 | 194 +++ .../internal/edist_spec_control_mod.F90 | 3 + src/etrans/etrans/internal/efsc_mod.F90 | 110 ++ src/etrans/etrans/internal/efscad_mod.F90 | 121 ++ src/etrans/etrans/internal/eftdir_ctl_mod.F90 | 214 +++ .../etrans/internal/eftdir_ctlad_mod.F90 | 201 +++ src/etrans/etrans/internal/eftdirad_mod.F90 | 119 ++ src/etrans/etrans/internal/eftinv_ctl_mod.F90 | 273 +++ .../etrans/internal/eftinv_ctlad_mod.F90 | 295 ++++ src/etrans/etrans/internal/eftinvad_mod.F90 | 128 ++ .../internal/egath_spec_control_mod.F90 | 201 +++ .../etrans/internal/einv_trans_ctl_mod.F90 | 298 ++++ .../etrans/internal/einv_trans_ctlad_mod.F90 | 292 ++++ src/etrans/etrans/internal/eledir_mod.F90 | 99 ++ src/etrans/etrans/internal/eledirad_mod.F90 | 118 ++ src/etrans/etrans/internal/eleinv_mod.F90 | 103 ++ src/etrans/etrans/internal/eleinvad_mod.F90 | 115 ++ src/etrans/etrans/internal/eltdir_ctl_mod.F90 | 117 ++ .../etrans/internal/eltdir_ctlad_mod.F90 | 109 ++ src/etrans/etrans/internal/eltdir_mod.F90 | 184 ++ src/etrans/etrans/internal/eltdirad_mod.F90 | 166 ++ src/etrans/etrans/internal/eltinv_ctl_mod.F90 | 129 ++ .../etrans/internal/eltinv_ctlad_mod.F90 | 116 ++ src/etrans/etrans/internal/eltinv_mod.F90 | 213 +++ src/etrans/etrans/internal/eltinvad_mod.F90 | 252 +++ src/etrans/etrans/internal/eprfi1_mod.F90 | 105 ++ src/etrans/etrans/internal/eprfi1ad_mod.F90 | 103 ++ src/etrans/etrans/internal/eprfi1b_mod.F90 | 110 ++ src/etrans/etrans/internal/eprfi1bad_mod.F90 | 110 ++ src/etrans/etrans/internal/eprfi2_mod.F90 | 85 + src/etrans/etrans/internal/eprfi2ad_mod.F90 | 82 + src/etrans/etrans/internal/eprfi2b_mod.F90 | 92 + src/etrans/etrans/internal/eprfi2bad_mod.F90 | 90 + src/etrans/etrans/internal/eset_resol_mod.F90 | 71 + .../etrans/internal/esetup_dims_mod.F90 | 46 + .../etrans/internal/esetup_geom_mod.F90 | 66 + .../etrans/internal/espnorm_ctl_mod.F90 | 64 + src/etrans/etrans/internal/espnormc_mod.F90 | 3 + src/etrans/etrans/internal/espnormd_mod.F90 | 55 + src/etrans/etrans/internal/espnsde_mod.F90 | 101 ++ src/etrans/etrans/internal/espnsdead_mod.F90 | 112 ++ src/etrans/etrans/internal/eupdsp_mod.F90 | 141 ++ src/etrans/etrans/internal/eupdspad_mod.F90 | 145 ++ src/etrans/etrans/internal/eupdspb_mod.F90 | 105 ++ src/etrans/etrans/internal/eupdspbad_mod.F90 | 133 ++ .../etrans/internal/euvtvd_comm_mod.F90 | 127 ++ src/etrans/etrans/internal/euvtvd_mod.F90 | 111 ++ src/etrans/etrans/internal/euvtvdad_mod.F90 | 128 ++ src/etrans/etrans/internal/evdtuv_mod.F90 | 125 ++ .../etrans/internal/evdtuvad_comm_mod.F90 | 163 ++ src/etrans/etrans/internal/evdtuvad_mod.F90 | 151 ++ src/etrans/etrans/internal/suefft_mod.F90 | 114 ++ .../etrans/internal/suemp_trans_mod.F90 | 267 +++ .../internal/suemp_trans_preleg_mod.F90 | 240 +++ src/etrans/etrans/internal/suemplat_mod.F90 | 252 +++ src/etrans/etrans/internal/suemplatb_mod.F90 | 236 +++ src/etrans/etrans/internal/suestaonl_mod.F90 | 451 +++++ src/etrans/etrans/internal/tpmald_dim.F90 | 23 + src/etrans/etrans/internal/tpmald_distr.F90 | 23 + src/etrans/etrans/internal/tpmald_fft.F90 | 20 + src/etrans/etrans/internal/tpmald_fields.F90 | 17 + src/etrans/etrans/internal/tpmald_geo.F90 | 22 + src/etrans/etrans/internal/tpmald_tcdis.F90 | 13 + src/programs/CMakeLists.txt | 9 + src/programs/ectrans-lam-benchmark.F90 | 1479 +++++++++++++++++ src/trans/CMakeLists.txt | 32 +- 118 files changed, 17227 insertions(+), 1 deletion(-) create mode 100644 src/etrans/CMakeLists.txt create mode 100644 src/etrans/biper/CMakeLists.txt create mode 100644 src/etrans/biper/external/etibihie.F90 create mode 100644 src/etrans/biper/external/fpbipere.F90 create mode 100644 src/etrans/biper/external/horiz_field.F90 create mode 100644 src/etrans/biper/include/etibihie.h create mode 100644 src/etrans/biper/include/fpbipere.h create mode 100644 src/etrans/biper/include/horiz_field.h create mode 100644 src/etrans/biper/internal/esmoothe_mod.F90 create mode 100644 src/etrans/biper/internal/espline_mod.F90 create mode 100644 src/etrans/biper/internal/ewindowe_mod.F90 create mode 100644 src/etrans/biper/internal/extper_mod.F90 create mode 100644 src/etrans/etrans/CMakeLists.txt create mode 100644 src/etrans/etrans/aux/ellips.F90 create mode 100644 src/etrans/etrans/aux/ellips.h create mode 100644 src/etrans/etrans/aux/ellips64.F90 create mode 100644 src/etrans/etrans/external/edir_trans.F90 create mode 100644 src/etrans/etrans/external/edir_transad.F90 create mode 100644 src/etrans/etrans/external/edist_grid.F90 create mode 100644 src/etrans/etrans/external/edist_spec.F90 create mode 100644 src/etrans/etrans/external/egath_grid.F90 create mode 100644 src/etrans/etrans/external/egath_spec.F90 create mode 100644 src/etrans/etrans/external/egpnorm_trans.F90 create mode 100644 src/etrans/etrans/external/einv_trans.F90 create mode 100644 src/etrans/etrans/external/einv_transad.F90 create mode 100644 src/etrans/etrans/external/esetup_trans.F90 create mode 100644 src/etrans/etrans/external/especnorm.F90 create mode 100644 src/etrans/etrans/external/etrans_end.F90 create mode 100644 src/etrans/etrans/external/etrans_inq.F90 create mode 100644 src/etrans/etrans/external/etrans_release.F90 create mode 100644 src/etrans/etrans/include/edir_trans.h create mode 100644 src/etrans/etrans/include/edir_transad.h create mode 100644 src/etrans/etrans/include/edist_grid.h create mode 100644 src/etrans/etrans/include/edist_spec.h create mode 100644 src/etrans/etrans/include/egath_grid.h create mode 100644 src/etrans/etrans/include/egath_spec.h create mode 100644 src/etrans/etrans/include/egpnorm_trans.h create mode 100644 src/etrans/etrans/include/einv_trans.h create mode 100644 src/etrans/etrans/include/einv_transad.h create mode 100644 src/etrans/etrans/include/esetup_trans.h create mode 100644 src/etrans/etrans/include/especnorm.h create mode 100644 src/etrans/etrans/include/etrans_end.h create mode 100644 src/etrans/etrans/include/etrans_inq.h create mode 100644 src/etrans/etrans/include/etrans_release.h create mode 100644 src/etrans/etrans/internal/cpl_int_mod.F90 create mode 100644 src/etrans/etrans/internal/easre1ad_mod.F90 create mode 100644 src/etrans/etrans/internal/easre1b_mod.F90 create mode 100644 src/etrans/etrans/internal/easre1bad_mod.F90 create mode 100644 src/etrans/etrans/internal/edealloc_resol_mod.F90 create mode 100644 src/etrans/etrans/internal/edir_trans_ctl_mod.F90 create mode 100644 src/etrans/etrans/internal/edir_trans_ctlad_mod.F90 create mode 100644 src/etrans/etrans/internal/edist_spec_control_mod.F90 create mode 100644 src/etrans/etrans/internal/efsc_mod.F90 create mode 100644 src/etrans/etrans/internal/efscad_mod.F90 create mode 100644 src/etrans/etrans/internal/eftdir_ctl_mod.F90 create mode 100644 src/etrans/etrans/internal/eftdir_ctlad_mod.F90 create mode 100644 src/etrans/etrans/internal/eftdirad_mod.F90 create mode 100644 src/etrans/etrans/internal/eftinv_ctl_mod.F90 create mode 100644 src/etrans/etrans/internal/eftinv_ctlad_mod.F90 create mode 100644 src/etrans/etrans/internal/eftinvad_mod.F90 create mode 100644 src/etrans/etrans/internal/egath_spec_control_mod.F90 create mode 100644 src/etrans/etrans/internal/einv_trans_ctl_mod.F90 create mode 100644 src/etrans/etrans/internal/einv_trans_ctlad_mod.F90 create mode 100644 src/etrans/etrans/internal/eledir_mod.F90 create mode 100644 src/etrans/etrans/internal/eledirad_mod.F90 create mode 100644 src/etrans/etrans/internal/eleinv_mod.F90 create mode 100644 src/etrans/etrans/internal/eleinvad_mod.F90 create mode 100644 src/etrans/etrans/internal/eltdir_ctl_mod.F90 create mode 100644 src/etrans/etrans/internal/eltdir_ctlad_mod.F90 create mode 100644 src/etrans/etrans/internal/eltdir_mod.F90 create mode 100644 src/etrans/etrans/internal/eltdirad_mod.F90 create mode 100644 src/etrans/etrans/internal/eltinv_ctl_mod.F90 create mode 100644 src/etrans/etrans/internal/eltinv_ctlad_mod.F90 create mode 100644 src/etrans/etrans/internal/eltinv_mod.F90 create mode 100644 src/etrans/etrans/internal/eltinvad_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi1_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi1ad_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi1b_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi1bad_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi2_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi2ad_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi2b_mod.F90 create mode 100644 src/etrans/etrans/internal/eprfi2bad_mod.F90 create mode 100644 src/etrans/etrans/internal/eset_resol_mod.F90 create mode 100644 src/etrans/etrans/internal/esetup_dims_mod.F90 create mode 100644 src/etrans/etrans/internal/esetup_geom_mod.F90 create mode 100644 src/etrans/etrans/internal/espnorm_ctl_mod.F90 create mode 100644 src/etrans/etrans/internal/espnormc_mod.F90 create mode 100644 src/etrans/etrans/internal/espnormd_mod.F90 create mode 100644 src/etrans/etrans/internal/espnsde_mod.F90 create mode 100644 src/etrans/etrans/internal/espnsdead_mod.F90 create mode 100644 src/etrans/etrans/internal/eupdsp_mod.F90 create mode 100644 src/etrans/etrans/internal/eupdspad_mod.F90 create mode 100644 src/etrans/etrans/internal/eupdspb_mod.F90 create mode 100644 src/etrans/etrans/internal/eupdspbad_mod.F90 create mode 100644 src/etrans/etrans/internal/euvtvd_comm_mod.F90 create mode 100644 src/etrans/etrans/internal/euvtvd_mod.F90 create mode 100644 src/etrans/etrans/internal/euvtvdad_mod.F90 create mode 100644 src/etrans/etrans/internal/evdtuv_mod.F90 create mode 100644 src/etrans/etrans/internal/evdtuvad_comm_mod.F90 create mode 100644 src/etrans/etrans/internal/evdtuvad_mod.F90 create mode 100644 src/etrans/etrans/internal/suefft_mod.F90 create mode 100644 src/etrans/etrans/internal/suemp_trans_mod.F90 create mode 100644 src/etrans/etrans/internal/suemp_trans_preleg_mod.F90 create mode 100644 src/etrans/etrans/internal/suemplat_mod.F90 create mode 100644 src/etrans/etrans/internal/suemplatb_mod.F90 create mode 100644 src/etrans/etrans/internal/suestaonl_mod.F90 create mode 100644 src/etrans/etrans/internal/tpmald_dim.F90 create mode 100644 src/etrans/etrans/internal/tpmald_distr.F90 create mode 100644 src/etrans/etrans/internal/tpmald_fft.F90 create mode 100644 src/etrans/etrans/internal/tpmald_fields.F90 create mode 100644 src/etrans/etrans/internal/tpmald_geo.F90 create mode 100644 src/etrans/etrans/internal/tpmald_tcdis.F90 create mode 100644 src/programs/ectrans-lam-benchmark.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 89c513c3e..aec33e15b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -60,6 +60,10 @@ ecbuild_add_option( FEATURE TRANSI DESCRIPTION "Compile TransI C-interface to trans" CONDITION HAVE_DOUBLE_PRECISION ) +ecbuild_add_option( FEATURE ETRANS + DEFAULT OFF + DESCRIPTION "Include Limited-Area-Model Transforms" ) + ectrans_find_lapack() ### Add sources and tests diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 7451aa03f..e6410ad64 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -11,3 +11,6 @@ add_subdirectory( programs ) if( HAVE_TRANSI ) add_subdirectory(transi) endif() +#if( HAVE_ETRANS ) +# add_subdirectory(etrans) +#endif() \ No newline at end of file diff --git a/src/etrans/CMakeLists.txt b/src/etrans/CMakeLists.txt new file mode 100644 index 000000000..7d8c39f0a --- /dev/null +++ b/src/etrans/CMakeLists.txt @@ -0,0 +1,2 @@ +add_subdirectory(biper) +add_subdirectory(etrans) \ No newline at end of file diff --git a/src/etrans/biper/CMakeLists.txt b/src/etrans/biper/CMakeLists.txt new file mode 100644 index 000000000..2159dc72e --- /dev/null +++ b/src/etrans/biper/CMakeLists.txt @@ -0,0 +1,44 @@ +## Assemble sources +ecbuild_list_add_pattern( LIST biper_src + GLOB + internal/* + external/* + QUIET + ) + +set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) +set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) + +foreach( prec sp dp ) + if( HAVE_${prec} ) + + ecbuild_add_library( + TARGET biper_${prec} + LINKER_LANGUAGE Fortran + SOURCES ${biper_src} + #PUBLIC_INCLUDES #$ + #$ + #$ + #$ + PUBLIC_LIBS fiat parkind_${prec} + PRIVATE_LIBS trans_${prec} + ) + + #target_link_libraries( biper_${prec} PUBLIC fiat parkind_${prec} trans_${prec}) + + # not sure if modules should be installed: shouldn't biper be accessed through interface routines? + ectrans_target_fortran_module_directory( + TARGET biper_${prec} + MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/biper_${prec} + INSTALL_DIRECTORY module/biper_${prec} + ) + + endif() +endforeach() + +## Install biper interface +file( GLOB biper_interface include/biper/* ) +install( + FILES ${biper_interface} + DESTINATION include/ectrans +) diff --git a/src/etrans/biper/external/etibihie.F90 b/src/etrans/biper/external/etibihie.F90 new file mode 100644 index 000000000..033adf85d --- /dev/null +++ b/src/etrans/biper/external/etibihie.F90 @@ -0,0 +1,101 @@ +SUBROUTINE ETIBIHIE(KDLON,KDGL,KNUBI,KDLUX,KDGUX,& + & KSTART,KDLSM,PGPBI,LDBIX,LDBIY,KDADD) + +!**** tool ETIBIHIE : Doubly-periodicisation : isotropic spline +! ------------- method. + +! purpose : +! -------- +! KNUBI horizontal fields which are known on C U I, +! are extended over E, in order to obtain doubly-periodic +! fields. +! IF LDBIX is equal .TRUE. , then the fields are periodicise +! in the x ( or longitude ) direction. If it is not the case, +! KDLUX must be equal to KDLON. +! IF LDBIY is equal .TRUE. , then the fields are periodicise +! in the y ( or latitude ) direction. If it is not the case, +! KDGUX must be equal to KDGL. + +!* *CALL* *ETIBIHIE*(...) + +! externals : +! ---------- +! ESPLIN spline extension +! ESMOOTH smoothing across to get isotropy. + +! explicit arguments : +! ------------------ +! KDLON : upper bound for the x (or longitude) dimension +! of the gridpoint array on C U I U E +! KDGL : upper bound for the y (or latitude) dimension +! of the gridpoint array on C U I U E +! KNUBI : number of horizontal fields to doubly-periodicise. +! KDLUX : upper bound for the x (or longitude) dimension +! of C U I. +! KDGUX : upper bound for the y (or latitude) dimension +! of C U I. +! KSTART : first dimension in x direction of g-p array +! KDLSM : second dimension in x direction of g-p array +! PGPBI : gridpoint array on C U I U E. +! LDBIX : logical to periodicize or not +! in the x ( or longitude ) direction. +! LDBIY : logical to periodicize or not +! in the y ( or latitude ) direction. +! KDADD : 1 to test biperiodiz. + +! references : +! ---------- + +! author : +! ------ +! V. Ducrocq + +! modification : +! ------------ +! A. Stanesic 28/03/2008: KDADD - test of externalized biper. +! ------------------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE ESPLINE_MOD +USE ESMOOTHE_MOD + +! ------------------------------------------------------------------------- + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI +INTEGER(KIND=JPIM),INTENT(IN) :: KSTART +INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM +INTEGER(KIND=JPIM),INTENT(IN) :: KDLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDADD +REAL(KIND=JPRB),INTENT(INOUT) :: PGPBI(KSTART:KDLSM+KDADD,KNUBI,1:KDGL+KDADD) +LOGICAL,INTENT(IN) :: LDBIX +LOGICAL,INTENT(IN) :: LDBIY + +! ------------------------------------------------------------------------- + +REAL(KIND=JPRB) :: ZALFA +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('ETIBIHIE',0,ZHOOK_HANDLE) +! ------------------------------------------------------------------------- + +!* 1. DOUBLY-PERIODICISE : +! ------------------ + +ZALFA = 0.0_JPRB + +CALL ESPLINE(1,KDLON,1,KDGL,KDLUX,KDGUX,KSTART,& + & KDLSM+KDADD,1,KDGL+KDADD,KNUBI,PGPBI,ZALFA,LDBIX,LDBIY,KDADD) +CALL ESMOOTHE(1,KDLON,1,KDGL,KDLUX,KDGUX,KSTART,& + & KDLSM+KDADD,1,KDGL+KDADD,KNUBI,PGPBI,LDBIX,LDBIY) + +! ------------------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('ETIBIHIE',1,ZHOOK_HANDLE) +END SUBROUTINE ETIBIHIE diff --git a/src/etrans/biper/external/fpbipere.F90 b/src/etrans/biper/external/fpbipere.F90 new file mode 100644 index 000000000..6395ca9f4 --- /dev/null +++ b/src/etrans/biper/external/fpbipere.F90 @@ -0,0 +1,157 @@ +SUBROUTINE FPBIPERE(KDLUX,KDGUX,KDLON,KDGL,KNUBI,KD1,PGPBI,KDADD,LDZON, & + & LDBOYD, KDBOYD, PLBOYD) + +!**** *FPBIPERE* - Full-POS interface for double periodicisation + +! purpose : +! -------- +! To bi-periodicise the post-processed fields, or just fill the extension zone +! with the mean value of C+I area + +!** INTERFACE. +! ---------- +! *CALL* *FPBIPERE*(...) + +! EXPLICIT ARGUMENTS +! -------------------- +! KDLUX : upper bound for the x (or longitude) dimension of C U I. +! KDGUX : upper bound for the y (or latitude) dimension of C U I. +! KDLON : upper bound for the x (or longitude) dimension of the gridpoint array on C U I U E +! KDGL : upper bound for the y (or latitude) dimension of the gridpoint array on C U I U E +! KNUBI : number of horizontal fields to doubly-periodicise. +! KD1 : dimension of input/output array +! PGPBI : input/output gridpoint array on C U I U E. +! LDZON : .true. if input grid on C U I U E (.false. if C U I) +! KDADD : 1 to test biperiodiz. +! LDBOYD: perform boyd periodization (inside C U I) +! KDBOYD: array containing dimensions of boyd domain +! PLBOYD: scalar parameter for boyd (variable L in paper) + +! IMPLICIT ARGUMENTS +! -------------------- + +! METHOD. +! ------- +! SEE DOCUMENTATION + +! EXTERNALS. +! ---------- +! ESPLINE spline extension +! ESMOOTHE smoothing across to get isotropy. + +! REFERENCE. +! ---------- +! ECMWF Research Department documentation of the IFS + +! AUTHOR. +! ------- +! RYAD EL KHATIB *METEO-FRANCE* + +! MODIFICATIONS. +! -------------- +! R. El Khatib : 01-08-07 Pruning options +! M.Hamrud : 01-Oct-2003 CY28 Cleaning +! F. Taillefer : 04-10-21 Add LDZON +! A. Stanesic : 28-03-08: KDADD - test of externalized biper. +! D. Degrauwe : feb 2012 Boyd periodization +! R. El Khatib 27-Sep-2013 Boyd periodization in Fullpos-2 +! R. El Khatib 04-Aug-2016 new interface to ewindowe + cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE ESPLINE_MOD +USE ESMOOTHE_MOD +USE EWINDOWE_MOD +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI +INTEGER(KIND=JPIM),INTENT(IN) :: KD1 +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDADD +REAL(KIND=JPRB) ,INTENT(INOUT) :: PGPBI(KD1,KNUBI) +LOGICAL, OPTIONAL ,INTENT(IN) :: LDZON +LOGICAL ,INTENT(IN) ,OPTIONAL :: LDBOYD +INTEGER(KIND=JPIM),INTENT(IN) ,OPTIONAL :: KDBOYD(6) +REAL(KIND=JPRB) ,INTENT(IN) ,OPTIONAL :: PLBOYD + +! ------------------------------------------------------------------ + +REAL(KIND=JPRB), ALLOCATABLE :: ZGPBI(:,:,:) +INTEGER(KIND=JPIM) :: IND, ISTAE, JGL, JLON, JNUBI, ILONF, ILATF, IBWX, IBWY +INTEGER(KIND=JPIM) :: IBWXH, IBWYH, IND1 +INTEGER(KIND=JPIM) :: ILONI(KDLON), ILATI(KDGL) +INTEGER(KIND=JPIM) :: IDLUN, IDGUN, IDLUX, IDGUX +LOGICAL :: LLZON, LLBOYD +REAL(KIND=JPRB) :: ZALFA +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +#include "abor1.intfb.h" + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('FPBIPERE',0,ZHOOK_HANDLE) +! ------------------------------------------------------------------ + +LLBOYD=.FALSE. +IF (PRESENT(LDBOYD)) LLBOYD=LDBOYD + + +!* 2. DOUBLY-PERIODICISE +! ------------------ + +IF (LLBOYD) THEN + IF (.NOT.PRESENT(KDBOYD)) CALL ABOR1('FPBIPERE: Boyd periodization requires KDBOYD argument') + IF (.NOT.PRESENT(PLBOYD)) CALL ABOR1('FPBIPERE: Boyd periodization requires PLBOYD argument') + IBWX=KDBOYD(3) + IBWY=KDBOYD(6) + CALL EWINDOWE(KDLON,KDLUX,IBWX,KDGL,KDGUX,IBWY,KNUBI,PGPBI,PLBOYD,.TRUE.,.TRUE.) +ELSE + LLZON=.FALSE. + IF(PRESENT(LDZON)) LLZON=LDZON + ALLOCATE(ZGPBI(KDLON+KDADD,KNUBI,KDGL+KDADD)) + IF(LLZON) THEN +! Copy C+I+E + IND=KDLON + ELSE +! Copy C+I + IND=KDLUX + ENDIF +!$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JNUBI,ISTAE,JGL,JLON) + DO JNUBI=1,KNUBI + ISTAE=0 + DO JGL=1,KDGUX + DO JLON=1,KDLUX + ZGPBI(JLON,JNUBI,JGL)=PGPBI(ISTAE+JLON,JNUBI) + ENDDO + ISTAE=ISTAE+IND + ENDDO + ENDDO +!$OMP END PARALLEL DO + ZALFA = 0.0_JPRB + CALL ESPLINE(1,KDLON,1,KDGL,KDLUX,KDGUX,1,KDLON+KDADD,1,KDGL+KDADD,KNUBI,ZGPBI,& + & ZALFA,.TRUE.,.TRUE.,KDADD) + CALL ESMOOTHE(1,KDLON,1,KDGL,KDLUX,KDGUX,1,KDLON+KDADD,1,KDGL+KDADD,KNUBI,ZGPBI,& + & .TRUE.,.TRUE.) +!$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JNUBI,ISTAE,JGL,JLON) + DO JNUBI=1,KNUBI + ISTAE=0 + DO JGL=1,KDGL + DO JLON=1,KDLON + PGPBI(ISTAE+JLON,JNUBI)=ZGPBI(JLON,JNUBI,JGL) + ENDDO + ISTAE=ISTAE+KDLON + ENDDO + ENDDO +!$OMP END PARALLEL DO + DEALLOCATE(ZGPBI) +ENDIF + + +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('FPBIPERE',1,ZHOOK_HANDLE) +END SUBROUTINE FPBIPERE diff --git a/src/etrans/biper/external/horiz_field.F90 b/src/etrans/biper/external/horiz_field.F90 new file mode 100644 index 000000000..0d66345c2 --- /dev/null +++ b/src/etrans/biper/external/horiz_field.F90 @@ -0,0 +1,66 @@ +SUBROUTINE HORIZ_FIELD(KX,KY,PHFIELD) + +! purpose : +! -------- +! To produce test horizontal field of temperature. + +! method : +! --------- +! Test horizontal input field is on horizontal grid size KXxKY points, and it +! represent's temperature. It is obtained form flollwing expression: +! PHFIELD(i,j)=280*(1+0.1*Sin[PPI*(i+0.5*IMAX)*(j+0.7*IMAX)/IMAX^2+1]) (Pierre Benard) + +! interface : +! --------- +! CALL HORIZ_FIELD(KX,KY,PHFIELD) + +! Explicit arguments : +! ------------------- +! KX - number of grid points in x +! KY - number of grid points in y +! PHFIELD - simulated 2D temperature horizontal field + +! externals : +! ---------- +! None. + +! references : +! ---------- + +! author : +! ------ +! 23-May-2008 Antonio Stanesic +! ---------------------------------------------------------------------- + +USE PARKIND1 , ONLY : JPIM ,JPRB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KX +INTEGER(KIND=JPIM), INTENT(IN) :: KY +REAL(KIND=JPRB), INTENT(OUT) :: PHFIELD(KX,KY) + +! ---------------------------------------------------------------------- + +REAL(KIND=JPRB), PARAMETER :: PPI=3.141592 +INTEGER(KIND=JPIM) :: JX,JY,IMAX +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('HORIZ_FIELD',0,ZHOOK_HANDLE) +! ---------------------------------------------------------------------- + +IMAX=MAX(KX,KY) + +DO JY=1,KY + DO JX=1,KX + PHFIELD(JX,JY)=280*(1+0.1*SIN(PPI*(JX+0.5*IMAX)*(JY+0.7*IMAX)/(IMAX**2)+1)) + ENDDO +ENDDO + +! ---------------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('HORIZ_FIELD',1,ZHOOK_HANDLE) +END SUBROUTINE HORIZ_FIELD diff --git a/src/etrans/biper/include/etibihie.h b/src/etrans/biper/include/etibihie.h new file mode 100644 index 000000000..53861fb33 --- /dev/null +++ b/src/etrans/biper/include/etibihie.h @@ -0,0 +1,22 @@ +INTERFACE +SUBROUTINE ETIBIHIE(KDLON,KDGL,KNUBI,KDLUX,KDGUX,& + & KSTART,KDLSM,PGPBI,LDBIX,LDBIY,KDADD) + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI +INTEGER(KIND=JPIM),INTENT(IN) :: KSTART +INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM +INTEGER(KIND=JPIM),INTENT(IN) :: KDLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDADD +REAL(KIND=JPRB),INTENT(INOUT) :: PGPBI(KSTART:KDLSM+KDADD,KNUBI,1:KDGL+KDADD) +LOGICAL,INTENT(IN) :: LDBIX +LOGICAL,INTENT(IN) :: LDBIY + +END SUBROUTINE ETIBIHIE +END INTERFACE diff --git a/src/etrans/biper/include/fpbipere.h b/src/etrans/biper/include/fpbipere.h new file mode 100644 index 000000000..16fbc0cd4 --- /dev/null +++ b/src/etrans/biper/include/fpbipere.h @@ -0,0 +1,19 @@ +INTERFACE +SUBROUTINE FPBIPERE(KDLUX,KDGUX,KDLON,KDGL,KNUBI,KD1,PGPBI,KDADD,LDZON,& +& LDBOYD,KDBOYD,PLBOYD,PBIPOUT) +USE PARKIND1 ,ONLY : JPIM ,JPRB +INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI +INTEGER(KIND=JPIM),INTENT(IN) :: KD1 +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDADD +REAL(KIND=JPRB) ,INTENT(INOUT):: PGPBI(KD1,KNUBI) +LOGICAL, OPTIONAL ,INTENT(IN) :: LDZON +LOGICAL, OPTIONAL ,INTENT(IN) :: LDBOYD +INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KDBOYD(6) +REAL(KIND=JPRB) , INTENT(IN), OPTIONAL :: PLBOYD +REAL(KIND=JPRB) ,INTENT(OUT), OPTIONAL :: PBIPOUT(:,:) +END SUBROUTINE FPBIPERE +END INTERFACE diff --git a/src/etrans/biper/include/horiz_field.h b/src/etrans/biper/include/horiz_field.h new file mode 100644 index 000000000..6acb5d64b --- /dev/null +++ b/src/etrans/biper/include/horiz_field.h @@ -0,0 +1,13 @@ +INTERFACE +SUBROUTINE HORIZ_FIELD(KX,KY,PHFIELD) + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KX +INTEGER(KIND=JPIM), INTENT(IN) :: KY +REAL(KIND=JPRB), INTENT(OUT) :: PHFIELD(KX,KY) +REAL(KIND=JPRB), PARAMETER :: PPI=3.141592 +END SUBROUTINE HORIZ_FIELD +END INTERFACE diff --git a/src/etrans/biper/internal/esmoothe_mod.F90 b/src/etrans/biper/internal/esmoothe_mod.F90 new file mode 100644 index 000000000..4d65fe998 --- /dev/null +++ b/src/etrans/biper/internal/esmoothe_mod.F90 @@ -0,0 +1,171 @@ +MODULE ESMOOTHE_MOD +CONTAINS +SUBROUTINE ESMOOTHE(KDLUN,KDLON,KDGUN,KDGL,KDLUX,KDGUX,KSTART,& + & KDLSM,KDGSA,KDGEN,KNUBI,PWORK,LDBIX,LDBIY) + +! purpose : +! -------- +! To smooth the fields over the extension zone. + +!* *CALL* *ESMOOTHE*(...) + +! externals : +! ---------- +! None + +! explicit arguments : +! ------------------ +! KDLUN : lower bound for the x (or longitude) dimension +! of the gridpoint array +! KDLON : upper bound for the x (or longitude) dimension +! of the gridpoint array on C U I U E +! KDGUN : lower bound for the y (or latitude) dimension +! of the gridpoint array +! KDGL : upper bound for the y (or latitude) dimension +! of the gridpoint array on C U I U E +! KDLUX : upper bound for the x (or longitude) dimension +! of C U I. +! KDGUX : upper bound for the y (or latitude) dimension +! of C U I. +! KDLSM : dimension in x direction of g-p array +! KDGSA : first dimension index in y of g-p array +! KDGEN : last dimension index in y of g-p array +! KSTART : first dimension index in x of g-p array +! KDLSM : last dimension index in x of g-p array +! KNUBI : number of levels to biperiodicise + +! PWORK : gridpoint array on C U I U E. + +! LDBIX : .TRUE.: biperiodicise in x direction (and vice versa) +! LDBIY : .TRUE.: biperiodicise in y direction (and vice versa) + +! references : +! ---------- + +! author : +! ------ +! Michal Batka and Radmila Bubnova ( B & B ) + +! modifications : +! ------------- +! R. El Khatib 03-05-05 Optimizations +! -------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +! -------------------------------------------------------------- + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KSTART +INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM +INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA +INTEGER(KIND=JPIM),INTENT(IN) :: KDGEN +INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUN +INTEGER(KIND=JPIM),INTENT(IN) :: KDLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUN +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(KSTART:KDLSM,KNUBI,KDGSA:KDGEN) +LOGICAL ,INTENT(IN) :: LDBIX +LOGICAL ,INTENT(IN) :: LDBIY + +! -------------------------------------------------------------- + +REAL(KIND=JPRB) :: ZPRAC(KDLUN-1:KDLON+1,KDGUN-1:KDGL+1) +INTEGER(KIND=JPIM) :: IEND, IENX1, IENX2, IENY1, IENY2, JFL, JLAT, JLL, JLON +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! -------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('ESMOOTHE',0,ZHOOK_HANDLE) +! -------------------------------------------------------------- + +!* 1. Calculation. +! ------------ + +IEND = MAX(KDLON-KDLUX,KDGL-KDGUX) +IEND = (IEND+1)/2 +IENX1= KDLON +IENX2= KDGL +IENY1= KDGL +IENY2= KDLON +IF(LDBIX.AND.(.NOT.LDBIY)) THEN + IENX2 = KDGUX + IENY1 = KDGUX +ELSEIF((.NOT.LDBIX).AND.LDBIY) THEN + IENX1 = KDLUX + IENY2 = KDLUX +ELSEIF((.NOT.LDBIX).AND.(.NOT.LDBIY)) THEN + IF (LHOOK) CALL DR_HOOK('ESMOOTHE',1,ZHOOK_HANDLE) + RETURN +ENDIF + +DO JFL = 1, KNUBI + + DO JLL = 1, IEND + + DO JLON = KDLUX,KDLON + DO JLAT = KDGUN,KDGL + ZPRAC(JLON,JLAT) = PWORK(JLON,JFL,JLAT) + ENDDO + ENDDO + + DO JLON = KDLUX,KDLON + ZPRAC(JLON,KDGUN-1) = PWORK(JLON,JFL,KDGL) + ZPRAC(JLON,KDGL +1) = PWORK(JLON,JFL,KDGUN) + ENDDO + DO JLAT = KDGUN,KDGL + ZPRAC(KDLON+1,JLAT) = PWORK(KDLUN,JFL,JLAT) + ENDDO + ZPRAC(KDLON+1,KDGUN-1) = PWORK(KDLUN,JFL,KDGL) + ZPRAC(KDLON+1,KDGL +1) = PWORK(KDLUN,JFL,KDGUN) + + DO JLON = KDLUX + JLL,IENX1 - JLL + 1 + DO JLAT = KDGUN, IENX2 + PWORK(JLON,JFL,JLAT)=(4._JPRB*ZPRAC(JLON,JLAT)+2.0_JPRB*(ZPRAC(JLON+& + & 1,JLAT)+& + & ZPRAC(JLON-1,JLAT) + ZPRAC(JLON,JLAT+1) +& + & ZPRAC(JLON,JLAT-1)) + ZPRAC(JLON+1,JLAT+1) +& + & ZPRAC(JLON-1,JLAT+1) + ZPRAC(JLON+1,JLAT-1)+& + & ZPRAC(JLON-1,JLAT-1))/16._JPRB + ENDDO + ENDDO + + DO JLAT = KDGUX,KDGL + DO JLON = KDLUN,KDLON + ZPRAC(JLON,JLAT) = PWORK(JLON,JFL,JLAT) + ENDDO + ENDDO + + DO JLAT = KDGUX,KDGL + ZPRAC(KDLUN-1,JLAT) = PWORK(KDLON,JFL,JLAT) + ZPRAC(KDLON+1,JLAT) = PWORK(KDLUN,JFL,JLAT) + ENDDO + DO JLON = KDLUN,KDLON + ZPRAC(JLON,KDGL +1) = PWORK(JLON,JFL,KDGUN) + ENDDO + ZPRAC(KDLUN-1,KDGL +1) = PWORK(KDLON,JFL,KDGUN) + ZPRAC(KDLON+1,KDGL +1) = PWORK(KDLUN,JFL,KDGUN) + + DO JLAT = KDGUX + JLL, IENY1 - JLL + 1 + DO JLON = KDLUN,IENY2 + PWORK(JLON,JFL,JLAT)=(4._JPRB*ZPRAC(JLON,JLAT)+2.0_JPRB*(ZPRAC(JLON+& + & 1,JLAT)+& + & ZPRAC(JLON-1,JLAT) + ZPRAC(JLON,JLAT+1) +& + & ZPRAC(JLON,JLAT-1)) + ZPRAC(JLON+1,JLAT+1) +& + & ZPRAC(JLON-1,JLAT+1) + ZPRAC(JLON+1,JLAT-1)+& + & ZPRAC(JLON-1,JLAT-1))/16._JPRB + ENDDO + ENDDO + + ENDDO + +ENDDO + +! -------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('ESMOOTHE',1,ZHOOK_HANDLE) +END SUBROUTINE ESMOOTHE +END MODULE ESMOOTHE_MOD diff --git a/src/etrans/biper/internal/espline_mod.F90 b/src/etrans/biper/internal/espline_mod.F90 new file mode 100644 index 000000000..e44880f19 --- /dev/null +++ b/src/etrans/biper/internal/espline_mod.F90 @@ -0,0 +1,189 @@ +MODULE ESPLINE_MOD +CONTAINS +SUBROUTINE ESPLINE(KDLUN,KDLON,KDGUN,KDGL,KDLUX,KDGUX,KSTART,& + & KDLSM,KDGSA,KDGEN,KNUBI,PWORK,PALFA,LDBIX,LDBIY,KDAD) + +! purpose : +! -------- +! Make spline extension. + +! *CALL* *ESPLINE*(...) + +! externals : +! ---------- +! None + +! explicit arguments : +! ------------------ +! KDLUN : lower bound for the x (or longitude) dimension +! of the gridpoint array +! KDLON : upper bound for the x (or longitude) dimension +! of the gridpoint array on C U I U E +! KDGUN : lower bound for the y (or latitude) dimension +! of the gridpoint array +! KDGL : upper bound for the y (or latitude) dimension +! of the gridpoint array on C U I U E +! KDLUX : upper bound for the x (or longitude) dimension +! of C U I. +! KDGUX : upper bound for the y (or latitude) dimension +! of C U I. +! KSTART : first dimension in x direction of g-p array +! KDLSM : last dimension in x direction of g-p array +! KDGSA : first dimension in y of g-p array +! KDGEN : last dimension in y of g-p array +! KNUBI : number of levels to biperiodicise +! PWORK : gridpoint array on C U I U E. +! PALFA : boundary condition of a spline: +! = 0. ... natural spline +! = 1. ... boundary condition computed differentially +! (additional option) +! LDBIX : .TRUE. biperiodicisation in x ( and vice versa ) +! LDBIY : .TRUE. biperiodicisation in y ( and vice versa ) +! KDAD : 1 for test of biperiodic. + +! references : +! ---------- + +! author : +! ------ +! Michal Batka and Radmila Bubnova ( B & B ) + +! modifications : +! ------------- +! J.Vivoda 03-2002 2D model fix +! A. Stanesic : 28-03-08: KDADD - test of externalized biper. +! ------------------------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +! ------------------------------------------------------------- + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KSTART +INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM +INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA +INTEGER(KIND=JPIM),INTENT(IN) :: KDGEN +INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUN +INTEGER(KIND=JPIM),INTENT(IN) :: KDLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUN +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(KSTART:KDLSM,KNUBI,KDGSA:KDGEN) +REAL(KIND=JPRB) ,INTENT(IN) :: PALFA +LOGICAL ,INTENT(IN) :: LDBIX +LOGICAL ,INTENT(IN) :: LDBIY +INTEGER(KIND=JPIM),INTENT(IN) :: KDAD + +! ------------------------------------------------------------- + +LOGICAL :: LLBIX +LOGICAL :: LLBIY +INTEGER(KIND=JPIM) :: IENDX, IENDY, JFL, JLAT, JLON, IA +REAL(KIND=JPRB) :: ZA, ZB, ZC, ZD, ZEPSA, ZEPSB, ZJ, ZK, ZKP1,& + & ZLAM, ZLAMB, ZM1, ZM2, ZMM, ZNY +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('ESPLINE',0,ZHOOK_HANDLE) +! ------------------------------------------------------------- + +!* 1. Spline Extension. +! ------------------- + +LLBIX=LDBIX +LLBIY=LDBIY + +IF( KDLUN==1.AND.KDLUX==1 ) LLBIX=.FALSE. +IF( KDGUN==1.AND.KDGUX==1 ) LLBIY=.FALSE. + +IENDX = KDGUX +IENDY = KDLON + +IF(LLBIX.AND.(.NOT.LLBIY)) THEN + IENDY = KDLUN - 1 + +ELSEIF((.NOT.LLBIX).AND.LLBIY) THEN + IENDX = KDGUN - 1 + IENDY = KDLUX + +ELSEIF((.NOT.LLBIX).AND.(.NOT.LLBIY)) THEN + IF (LHOOK) CALL DR_HOOK('ESPLINE',1,ZHOOK_HANDLE) + RETURN +ENDIF +DO JFL = 1, KNUBI + + ZK = REAL(KDLON-KDLUX+1,JPRB) + ZKP1 = ZK + 1.0_JPRB + ZLAMB = ZK/ZKP1 + ZNY = PALFA/ZKP1 + + DO JLAT=KDGUN,IENDX + + ZEPSA = ((PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK -& + & PWORK(KDLUX,JFL,JLAT)+PWORK(KDLUX-1,JFL,JLAT))*6._JPRB/ZKP1 -& + & ZNY*(PWORK(KDLUX,JFL,JLAT)-2.0_JPRB* PWORK(KDLUX-1,JFL,JLAT)+& + & PWORK(KDLUX-2,JFL,JLAT)) + + ZEPSB = (PWORK(KDLUN+1,JFL,JLAT)-PWORK(KDLUN,JFL,JLAT) -& + & (PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK)*6._JPRB/ZKP1-& + & ZNY*(PWORK(KDLUN+2,JFL,JLAT)-2.0_JPRB* PWORK(KDLUN+1,JFL,JLAT)+& + & PWORK(KDLUN,JFL,JLAT)) + + ZMM = 4._JPRB - ZLAMB*ZLAMB + ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ZMM + ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ZMM + ZA = PWORK(KDLUX,JFL,JLAT) + ZB = (PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK-& + & (2.0_JPRB*ZM1 + ZM2) * ZK/6._JPRB + ZC = 0.5_JPRB * ZM1 + ZD = (ZM2 - ZM1)/(6._JPRB*ZK) + + DO JLON=KDLUX+1,KDLON+KDAD + ZJ = REAL(JLON - KDLUX,JPRB) + PWORK(JLON,JFL,JLAT) = ZA + ZJ * (ZB + ZJ * (ZC + ZD * ZJ)) + ENDDO + ENDDO + + ZK = REAL(KDGL - KDGUX + 1,JPRB) + ZKP1 = ZK + 1 + ZLAM = ZK/ZKP1 + ZNY = PALFA/ZKP1 + + DO JLON=KDLUN,IENDY+KDAD + + ZEPSA = ((PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK -& + & PWORK(JLON,JFL,KDGUX)+PWORK(JLON,JFL,KDGUX-1))*6._JPRB/ZKP1-& + & ZNY*(PWORK(JLON,JFL,KDGUX)-2.0_JPRB*PWORK(JLON,JFL,KDGUX-1)+& + & PWORK(JLON,JFL,KDGUX-2)) + + ZEPSB = (PWORK(JLON,JFL,KDGUN+1)-PWORK(JLON,JFL,KDGUN) -& + & (PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK)*6._JPRB/ZKP1-& + & ZNY*(PWORK(JLON,JFL,KDGUN+2)-2.0_JPRB*PWORK(JLON,JFL,KDGUN+1) +& + & PWORK(JLON,JFL,KDGUN)) + + ZMM = 4._JPRB - ZLAMB*ZLAMB + ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ ZMM + ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ ZMM + ZA = PWORK(JLON,JFL,KDGUX) + ZB = (PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK - (2.0_JPRB*& + & ZM1 & + & + ZM2) * ZK/6._JPRB + ZC = 0.5_JPRB * ZM1 + ZD = (ZM2 - ZM1)/(6._JPRB*ZK) + + DO JLAT=KDGUX+1,KDGL+KDAD + ZJ = REAL(JLAT - KDGUX,JPRB) + PWORK(JLON,JFL,JLAT) = ZA +ZJ*(ZB +ZJ*(ZC + ZJ * ZD)) + ENDDO + ENDDO + +ENDDO + +! ------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('ESPLINE',1,ZHOOK_HANDLE) +END SUBROUTINE ESPLINE +END MODULE ESPLINE_MOD diff --git a/src/etrans/biper/internal/ewindowe_mod.F90 b/src/etrans/biper/internal/ewindowe_mod.F90 new file mode 100644 index 000000000..8d49a3379 --- /dev/null +++ b/src/etrans/biper/internal/ewindowe_mod.F90 @@ -0,0 +1,162 @@ +MODULE EWINDOWE_MOD + +CONTAINS + +SUBROUTINE EWINDOWE(KDLON,KDLUX,KBWX,KDGL,KDGUX,KBWY,KFLD,PGPIN,PSCAL,LDBIX,LDBIY) + +! purpose : +! -------- +! Make boyd periodic extension. + +! externals : +! ---------- +! None + +! explicit arguments : +! ------------------ +! KDLON : upper bound for the x (or longitude) dimension +! of C U I U P. +! KDGL : upper bound for the y (or latitude) dimension +! of the gridpoint array on C U I U P +! PGPIN : gridpoint array on C U I U P (gp:fields). +! PSCAL : window function scaling parameter +! LDBIX : .TRUE. windowing in x direction ( and vice versa ) +! LDBIY : .TRUE. windowing in y direction ( and vice versa ) + + +! references : +! ---------- + +! author : Fabrice Voitus and Piet Termonia, 07/2009 +! ------ +! +! modification : +! Daan Degrauwe 02/2012 Cleaned and generalized +! S. Martinez 03/2012 Calls to ERF under CPP key __PGI +! (ERF function is not intrinsic with PGI) +! R. El Khatib 27-Sep-2013 implicit sized PGPIN +! R. El Khatib 04-Aug-2016 new interface +! ----------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KDLON +INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX +INTEGER(KIND=JPIM),INTENT(IN) :: KBWX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(IN) :: KBWY +INTEGER(KIND=JPIM),INTENT(IN) :: KFLD +REAL(KIND=JPRB) ,INTENT(INOUT) :: PGPIN((KDLUX+2*KBWX+2*(KDLON-KDLUX))*(KDGUX+2*KBWY+2*(KDGL-KDGUX)),KFLD) +REAL(KIND=JPRB) ,INTENT(IN) :: PSCAL +LOGICAL ,INTENT(IN) :: LDBIX +LOGICAL ,INTENT(IN) :: LDBIY + +! FERF function +! ------------- + +#ifdef __PGI +REAL(KIND=JPRB), EXTERNAL :: ERF +#endif + +! scalars +! -------- + +INTEGER(KIND=JPIM) :: JFL, JGL, JLON, IOFF, IDLW, IDGW +INTEGER(KIND=JPIM) :: IWX, ILWX, IRWX, IWY, ILWY, IRWY, IBWXO, IBWYO +INTEGER(KIND=JPIM) :: ILATF, ILONF, IND1, IND, IOFF_LEFT,IOFF_RIGHT,IOFF_BOTTOM,IOFF_TOP +REAL(KIND=JPRB) :: ZI, ZJ, ZK, ZL +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! local arrays : +! ------------ + +REAL(KIND=JPRB) :: ZBELX(2*KBWX+(KDLON-KDLUX)) +REAL(KIND=JPRB) :: ZBELY(2*KBWY+(KDGL -KDGUX)) + +!* 1. Boyd Bi-periodic Extension Method. +! --------------------------------- + +IF (LHOOK) CALL DR_HOOK('EWINDOWE',0,ZHOOK_HANDLE) + +IF ((.NOT.LDBIX).AND.(.NOT.LDBIY)) THEN + IF (LHOOK) CALL DR_HOOK('EWINDOWE',1,ZHOOK_HANDLE) + RETURN +ENDIF + +IDGW=SIZE(ZBELY) +IDLW=SIZE(ZBELX) + +! Bell window functions : +! --------------------- + +IF (LDBIX) THEN + DO JLON=1,IDLW + ! variable between -1 and 1 + ZJ=REAL(-IDLW-1+2*JLON,JPRB)/(IDLW+1) + ZL=ZJ/SQRT(1.0_JPRB-(ZJ*ZJ)) +#ifdef __PGI + ZBELX(JLON)=(1.0_JPRB+ERF(REAL(PSCAL*ZL)))/2.0_JPRB +#else + ZBELX(JLON)=(1.0_JPRB+ERF(PSCAL*ZL))/2.0_JPRB +#endif + ENDDO +ENDIF + +IF (LDBIY) THEN + DO JGL=1,IDGW + ! variable between -1 and 1 + ZJ=REAL(-IDGW-1+2*JGL,JPRB)/(IDGW+1) + ZL=ZJ/SQRT(1.0_JPRB-(ZJ*ZJ)) +#ifdef __PGI + ZBELY(JGL)=(1.0_JPRB+ERF(REAL(PSCAL*ZL)))/2.0_JPRB +#else + ZBELY(JGL)=(1.0_JPRB+ERF(PSCAL*ZL))/2.0_JPRB +#endif + ENDDO +ENDIF + + +! Windowing on P+G-zone : +! -------------------- + +IOFF=(KDLUX+2*(KBWX+KDGL-KDGUX)) +IBWXO=KBWX+(KDLON-KDLUX) +IBWYO=KBWY+(KDGL-KDGUX) + +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFL,JGL,JLON,ILONF,ILATF,IND1,IND,IOFF_LEFT,IOFF_RIGHT,IOFF_BOTTOM,IOFF_TOP) +DO JFL=1,KFLD + IF (LDBIX) THEN + ! X-direction + DO JGL=1,KDGL+IDGW + IOFF_LEFT=(JGL-1)*IOFF + IOFF_RIGHT=IOFF_LEFT+KDLON + DO JLON=1,IDLW + PGPIN(IOFF_RIGHT+JLON,JFL) = ZBELX(JLON)*PGPIN(IOFF_LEFT+JLON,JFL) +& + & (1.0_JPRB-ZBELX(JLON))*PGPIN(IOFF_RIGHT+JLON,JFL) + ENDDO + ENDDO + ENDIF + IF (LDBIY) THEN + ! Y-direction + DO JGL=1,IDGW + IOFF_BOTTOM=(JGL-1)*IOFF + IOFF_TOP=(KDGL+JGL-1)*IOFF +!DIR$ IVDEP + DO JLON=1,KDLON+IDLW + PGPIN(IOFF_TOP+JLON,JFL) = ZBELY(JGL)*PGPIN(IOFF_BOTTOM+JLON,JFL) +& + & (1.0_JPRB-ZBELY(JGL))*PGPIN(IOFF_TOP+JLON,JFL) + ENDDO + ENDDO + ENDIF +ENDDO +!$OMP END PARALLEL DO + +IF (LHOOK) CALL DR_HOOK('EWINDOWE',1,ZHOOK_HANDLE) + +END SUBROUTINE EWINDOWE + +END MODULE EWINDOWE_MOD diff --git a/src/etrans/biper/internal/extper_mod.F90 b/src/etrans/biper/internal/extper_mod.F90 new file mode 100644 index 000000000..8135d8048 --- /dev/null +++ b/src/etrans/biper/internal/extper_mod.F90 @@ -0,0 +1,144 @@ +MODULE EXTPER_MOD +CONTAINS +SUBROUTINE EXTPER(PWORK,KDIM,KPSTA,KPOINTS,KFLDS,KUNITS,& + & KPOINTERS,KALFA) + +! purpose : +! -------- +! Make spline extension. + +! *CALL* *EXTPER(PWORK,KDIM,KPSTA,KPOINTS,KFLDS,KUNITS,& +! & KPOINTERS,KALFA) + +! externals : +! ---------- +! None + +! explicit arguments : +! ------------------ +! PWORK : Input: values in C U I area +! : Output: input+(spline extension on the E area) +! KDIM : Dimension of the C U I U E unit of work (one row or one m) +! KPSTA : Position where the unit of work starts +! KPOINTS : Position where the unit of work ends +! KFLDS : number of 2D fields +! KUNITS : Number of units of work +! KPOINTERS : Array of pointers for the units of work +! KALFA : boundary condition of a spline: +! = 0 ... natural spline +! = 1 ... boundary condition computed differentially +! (additional option) +! references : +! ---------- + +! author : +! ------ +! M. Hortal 03-11-2009 +! ----------------------------------------------- + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN +USE TPM_DISTR + +IMPLICIT NONE + +REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(:,:) +INTEGER(KIND=JPIM),INTENT(IN) :: KDIM +INTEGER(KIND=JPIM),INTENT(IN) :: KPSTA +INTEGER(KIND=JPIM),INTENT(IN) :: KPOINTS +INTEGER(KIND=JPIM),INTENT(IN) :: KFLDS +INTEGER(KIND=JPIM),INTENT(IN) :: KUNITS +INTEGER(KIND=JPIM),INTENT(IN) :: KPOINTERS(:) +INTEGER(KIND=JPIM),INTENT(IN) :: KALFA + +! arrays : +! -------- +INTEGER(KIND=JPIM) :: IENDX, IENDY, JFL, JLAT, JLON, IA + +REAL(KIND=JPRB) :: ZA, ZB, ZC, ZD, ZEPSA, ZEPSB, ZJ, ZK, ZKP1,& + & ZLAM, ZLAMB, ZM1, ZM2, ZMM, ZNY +REAL(KIND=JPRB) :: ZMAX(KUNITS), ZMIN(KUNITS) +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +#include "abor1.intfb.h" + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EXTPER',0,ZHOOK_HANDLE) + +!* 0. Security +! -------- + +IF(UBOUND(PWORK,1) < KFLDS) THEN + CALL ABOR1(' EXTPER, PWORK first dimension too small') +ENDIF +IF(UBOUND(PWORK,2) < KDIM+2) THEN + WRITE(NOUT,*) ' UBOUND(PWORK,2)=',UBOUND(PWORK,2),' KDIM=',KDIM,' KUNITS=',& + &KUNITS + CALL ABOR1(' EXTPER, PWORK second dimension too small') +ENDIF +IF(UBOUND(KPOINTERS,1) < KUNITS) THEN + CALL ABOR1(' EXTPER, KPOINTERS too small') +ENDIF +IF(UBOUND(PWORK,2) < KPOINTERS(KUNITS)+KDIM) THEN + WRITE(NERR,*) ' EXTPER, KUNITS=',KUNITS,' KPOINTERS=',KPOINTERS(1:KUNITS),& + &' KDIM=',KDIM,' UBOUND(PWORK,2)=',UBOUND(PWORK,2) + CALL ABOR1(' EXTPER, value of KPOINTERS too large') +ENDIF + +!* 1. Spline Extension. +! ------------------- + +DO JFL = 1, KFLDS + + ZK = REAL(KDIM-KPOINTS+1,JPRB) + ZKP1 = ZK + 1.0_JPRB + ZLAMB = ZK/ZKP1 + ZNY = REAL(KALFA,JPRB)/ZKP1 + + DO JLAT=1,KUNITS + ZEPSA = & + &((PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& + & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK -& + & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS)+& + & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-1))*6._JPRB/ZKP1 -& + & ZNY*(PWORK(JFL,KPOINTERS(JLAT)+KPOINTS)-& + & 2.0_JPRB* PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-1)+& + & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-2)) + + ZEPSB = (PWORK(JFL,KPOINTERS(JLAT)+KPSTA+1)-& + & PWORK(JFL,KPOINTERS(JLAT)+KPSTA) -& + & (PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& + & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK)*6._JPRB/ZKP1-& + & ZNY*(PWORK(JFL,KPOINTERS(JLAT)+KPSTA+2)-& + & 2.0_JPRB* PWORK(JFL,KPOINTERS(JLAT)+KPSTA+1)+& + & PWORK(JFL,KPOINTERS(JLAT)+KPSTA)) + + ZMM = 4._JPRB - ZLAMB*ZLAMB + ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ZMM + ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ZMM + ZA = PWORK(JFL,KPOINTERS(JLAT)+KPOINTS) + ZB = (PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& + & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK-& + & (2.0_JPRB*ZM1 + ZM2) * ZK/6._JPRB + ZC = 0.5_JPRB * ZM1 + ZD = (ZM2 - ZM1)/(6._JPRB*ZK) + + + DO JLON=KPOINTERS(JLAT)+KPOINTS+1,KPOINTERS(JLAT)+KDIM + + ZJ = REAL(JLON - (KPOINTERS(JLAT)+KPOINTS),JPRB) + PWORK(JFL,JLON) = ZA + ZJ * (ZB + ZJ * (ZC + ZD * ZJ)) + ENDDO + ENDDO + + +ENDDO + +IF (LHOOK) CALL DR_HOOK('EXTPER',1,ZHOOK_HANDLE) +END SUBROUTINE EXTPER +END MODULE EXTPER_MOD diff --git a/src/etrans/etrans/CMakeLists.txt b/src/etrans/etrans/CMakeLists.txt new file mode 100644 index 000000000..a29547d27 --- /dev/null +++ b/src/etrans/etrans/CMakeLists.txt @@ -0,0 +1,54 @@ + +## Assemble sources + +ecbuild_list_add_pattern( LIST etrans_src + GLOB + internal/* + external/* + aux/*.F90 + QUIET + ) + +set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) +set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) + +foreach( prec sp dp ) + if( HAVE_${prec} ) + + ecbuild_add_library( + TARGET etrans_${prec} + LINKER_LANGUAGE Fortran + SOURCES ${etrans_src} + PUBLIC_INCLUDES #$ + $ + $ + #$ + PUBLIC_LIBS fiat parkind_${prec} + PRIVATE_LIBS trans_${prec} biper_${prec} + ) + ectrans_target_fortran_module_directory( + TARGET etrans_${prec} + MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/etrans_${prec} + INSTALL_DIRECTORY module/etrans_${prec} + ) + #target_link_libraries( biper_${prec} PUBLIC fiat parkind_${prec} trans_${prec} biper_${prec}) + #if( HAVE_FFTW ) # already resolved from trans, I presume + # target_link_libraries( etrans_${prec} ${FFTW_LINK} ${FFTW_LIBRARIES} ) + # target_include_directories( etrans_${prec} PRIVATE ${FFTW_INCLUDE_DIRS} ) + # target_compile_definitions( etrans_${prec} PRIVATE WITH_FFTW ) + #endif() + #target_link_libraries( etrans_${prec} ${LAPACK_LINK} ${LAPACK_${prec}} ) # lapack isn't used by etrans + #if( HAVE_OMP ) # already resolved from trans, I presume + # target_link_libraries( etrans_${prec} PRIVATE OpenMP::OpenMP_Fortran ) + #endif() + + endif() +endforeach() + +## Install trans interface + +file( GLOB etrans_interface include/etrans/* ) +install( + FILES ${etrans_interface} + DESTINATION include/ectrans +) diff --git a/src/etrans/etrans/aux/ellips.F90 b/src/etrans/etrans/aux/ellips.F90 new file mode 100644 index 000000000..e3af47323 --- /dev/null +++ b/src/etrans/etrans/aux/ellips.F90 @@ -0,0 +1,8 @@ +! Oct-2012 P. Marguinaud 64b LFI + +#undef JLIK +#undef _ELLIPS_ +#define JLIK JPIM +#define _ELLIPS_ ELLIPS +#include "ellips.h" + diff --git a/src/etrans/etrans/aux/ellips.h b/src/etrans/etrans/aux/ellips.h new file mode 100644 index 000000000..1e82d565e --- /dev/null +++ b/src/etrans/etrans/aux/ellips.h @@ -0,0 +1,91 @@ +! Jan-2011 P. Marguinaud Interface to thread-safe FA +SUBROUTINE _ELLIPS_ (KSMAX,KMSMAX,KNTMP,KMTMP) +USE PARKIND1, ONLY : JPRB, JPRD, JPIM, JPIB +USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK +IMPLICIT NONE +! +! ***ELLIPS*** - General routine for computing elliptic truncation +! +! Purpose. +! -------- +! Computation of zonal and meridional limit wavenumbers within the ellipse +! Interface: +! ---------- +! *CALL* *ELLIPS * +! +! Explicit arguments : +! -------------------- +! +! Implicit arguments : +! -------------------- +! +! +! Method. +! ------- +! See documentation +! +! Externals. NONE. +! ---------- +! +! Reference. +! ---------- +! ARPEGE/ALADIN documentation +! +! Author. +! ------- +! G. Radnoti LACE 97/04/04 +! +! Modifications. +! +!------------------------------------------------------------- +! J.Vivoda, 99/05/19 treating NSMAX=0 and NMSMAX=0 +! O.Nuissier, 23/09/01 Change type of real (simple --> +! double precision) +! +! +INTEGER (KIND=JLIK) KSMAX, KMSMAX +INTEGER (KIND=JLIK) KNTMP(0:KMSMAX),KMTMP(0:KSMAX) +! +INTEGER (KIND=JLIK) JM, JN +! +REAL (KIND=JPRD) ZEPS, ZKN, ZKM, ZAUXIL +! +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +IF (LHOOK) CALL DR_HOOK('ELLIPS',0,ZHOOK_HANDLE) +ZEPS=1.E-10 +ZAUXIL=0. +! +! 1. Computing meridional limit wavenumbers along zonal wavenumbers +! +DO JM=1,KMSMAX-1 +ZKN = REAL(KSMAX,JPRD)/REAL(KMSMAX,JPRD)* & +& SQRT(MAX(ZAUXIL,REAL(KMSMAX**2-JM**2,JPRD))) + KNTMP(JM)=INT(ZKN+ZEPS, JLIK) +ENDDO + +IF( KMSMAX.EQ.0 )THEN + KNTMP(0)=KSMAX +ELSE + KNTMP(0)=KSMAX + KNTMP(KMSMAX)=0 +ENDIF +! +! 2. Computing zonal limit wavenumbers along meridional wavenumbers +! +DO JN=1,KSMAX-1 +ZKM = REAL(KMSMAX,JPRD)/REAL(KSMAX,JPRD)* & + & SQRT(MAX(ZAUXIL,REAL(KSMAX**2-JN**2,JPRD))) + KMTMP(JN)=INT(ZKM+ZEPS, JLIK) +ENDDO + +IF( KSMAX.EQ.0 )THEN + KMTMP(0)=KMSMAX +ELSE + KMTMP(0)=KMSMAX + KMTMP(KSMAX)=0 +ENDIF +! +IF (LHOOK) CALL DR_HOOK('ELLIPS',1,ZHOOK_HANDLE) +END + + diff --git a/src/etrans/etrans/aux/ellips64.F90 b/src/etrans/etrans/aux/ellips64.F90 new file mode 100644 index 000000000..083938214 --- /dev/null +++ b/src/etrans/etrans/aux/ellips64.F90 @@ -0,0 +1,8 @@ +! Oct-2012 P. Marguinaud 64b LFI + +#undef JLIK +#undef _ELLIPS_ +#define JLIK JPIB +#define _ELLIPS_ ELLIPS64 +#include "ellips.h" + diff --git a/src/etrans/etrans/external/edir_trans.F90 b/src/etrans/etrans/external/edir_trans.F90 new file mode 100644 index 000000000..bfebffaf2 --- /dev/null +++ b/src/etrans/etrans/external/edir_trans.F90 @@ -0,0 +1,500 @@ +SUBROUTINE EDIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV,AUX_PROC) + +!**** *EDIR_TRANS* - Direct spectral transform (from grid-point to spectral). + +! Purpose. +! -------- +! Interface routine for the direct spectral transform + +!** Interface. +! ---------- +! CALL EDIR_TRANS(...) + +! Explicit arguments : All arguments except from PGP are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (output) +! PSPDIV(:,:) - spectral divergence (output) +! PSPSCALAR(:,:) - spectral scalarvalued fields (output) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (input) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) + +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split + +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling DIR_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. + +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A ) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 ) +! PMEANU(:),PMEANV(:) - mean wind +! AUX_PROC - optional external procedure for biperiodization of +! aux.fields + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ELTDIR_CTL - control of Legendre transform +! EFTDIR_CTL - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! G. Radnoti: 01-03-13 adaptation to aladin +! P. Smolikova 02-09-30 : AUX_PROC for d4 in NH +! Y. Seity and G. Radnoti : 03-09-29 : phasing for AL27 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Bogatchev 19-04-2013 Comparison of ubound(pspdiv,1) +! with ubound(pspvor,1) +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR, NOUT +USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & + & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA +USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE EDIR_TRANS_CTL_MOD ,ONLY : EDIR_TRANS_CTL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANV(:) +EXTERNAL AUX_PROC +OPTIONAL AUX_PROC + +!ifndef INTERFACE + +! Local variables +INTEGER(KIND=JPIM) :: IUBOUND(4),J +INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP +INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Set current resolution +IF (LHOOK) CALL DR_HOOK('EDIR_TRANS',0,ZHOOK_HANDLE) +CALL GSTATS(1808,0) +CALL ESET_RESOL(KRESOL) + +! Set defaults + +IF_UV = 0 +IF_UV_G = 0 +IF_SCALARS = 0 +IF_SCALARS_G = 0 +NF_SC2 = 0 +NF_SC3A = 0 +NF_SC3B = 0 +IF_SC2_G = 0 +IF_SC3A_G = 0 +IF_SC3B_G = 0 +NPROMA = D%NGPTOT +! This is for use in TRGTOL which is shared with adjoint inverse transform +LSCDERS=.FALSE. +LVORGP=.FALSE. +LDIVGP=.FALSE. +LUVDER=.FALSE. + +! Decide requirements + +IF(PRESENT(KVSETUV)) THEN + IF_UV_G = UBOUND(KVSETUV,1) + DO J=1,IF_UV_G + IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETUV(J) == MYSETV) THEN + IF_UV = IF_UV+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPVOR)) THEN + IF_UV = UBOUND(PSPVOR,1) + IF_UV_G = IF_UV +ENDIF + +IF(PRESENT(KVSETSC)) THEN + IF_SCALARS_G = UBOUND(KVSETSC,1) + DO J=1,IF_SCALARS_G + IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETSC TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSCALAR)) THEN + IF_SCALARS = UBOUND(PSPSCALAR,1) + IF_SCALARS_G = IF_SCALARS +ENDIF + +IF(PRESENT(KVSETSC2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') + ENDIF + IF_SC2_G = UBOUND(KVSETSC2,1) + IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G + DO J=1,UBOUND(KVSETSC2,1) + IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETSC2 TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC2(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + NF_SC2 = NF_SC2+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC2)) THEN + IF_SC2_G = UBOUND(PSPSC2,1) + NF_SC2 = UBOUND(PSPSC2,1) + IF_SCALARS = IF_SCALARS+NF_SC2 + IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G +ENDIF + +IF(PRESENT(KVSETSC3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') + ENDIF + IF_SC3A_G = UBOUND(KVSETSC3A,1) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) + DO J=1,UBOUND(KVSETSC3A,1) + IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3A(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,3) + NF_SC3A = NF_SC3A+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3A)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,1)*UBOUND(PSPSC3A,3) + IF_SC3A_G = UBOUND(PSPSC3A,1) + IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) + NF_SC3A = UBOUND(PSPSC3A,1) +ENDIF + +IF(PRESENT(KVSETSC3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') + ENDIF + IF_SC3B_G = UBOUND(KVSETSC3B,1) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) + DO J=1,UBOUND(KVSETSC3B,1) + IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3B(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,3) + NF_SC3B = NF_SC3B+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3B)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,1)*UBOUND(PSPSC3B,3) + IF_SC3B_G = UBOUND(PSPSC3B,1) + IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) + NF_SC3B = UBOUND(PSPSC3B,1) +ENDIF + +IF(PRESENT(KPROMA)) THEN + NPROMA = KPROMA +ENDIF + +! Compute derived variables + +NGPBLKS = (D%NGPTOT-1)/NPROMA+1 + +IF_FS = 2*IF_UV + IF_SCALARS + +IF_GP = 2*IF_UV_G+IF_SCALARS_G + +! Consistency checks + +IF (IF_UV > 0) THEN + IF(.NOT. PRESENT(PSPVOR) ) THEN + CALL ABORT_TRANS('DIR_TRANS : IF_UV > 0 BUT PSPVOR MISSING') + ENDIF + IF(UBOUND(PSPVOR,1) < IF_UV) THEN + WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV + CALL ABORT_TRANS('DIR_TRANS : PSPVOR TOO SHORT') + ENDIF + IF(.NOT. PRESENT(PSPDIV) ) THEN + CALL ABORT_TRANS('DIR_TRANS : PSPVOR PRESENT BUT PSPDIV MISSING') + ENDIF + IF(UBOUND(PSPDIV,1) /= UBOUND(PSPVOR,1)) THEN + WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV + CALL ABORT_TRANS('DIR_TRANS : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') + ENDIF +ENDIF + +IF (IF_SCALARS > 0) THEN + IF(PRESENT(PSPSCALAR)) THEN + IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN + WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& + & UBOUND(PSPSCALAR,1),IF_SCALARS + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') + ENDIF + IF(PRESENT(PSPSC3A))THEN + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC3B))THEN + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC2))THEN + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') + ENDIF + ENDIF +ENDIF + +IF(NPRTRV >1) THEN + IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN + WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& + & NPRTRV,IF_UV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSCALAR) .AND. .NOT. PRESENT(KVSETSC)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSCALAR) AND NOT PRESENT(KVSETSC)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC2) .AND. .NOT. PRESENT(KVSETSC2)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC2) AND NOT PRESENT(KVSETSC2)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3A) .AND. .NOT. PRESENT(KVSETSC3A)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3A) AND NOT PRESENT(KVSETSC3A)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3B) .AND. .NOT. PRESENT(KVSETSC3B)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3B) AND NOT PRESENT(KVSETSC3B)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF +ENDIF + +IF(PRESENT(PGP)) THEN + IUBOUND(1:3)=UBOUND(PGP) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(2) < IF_GP) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP + CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') + ENDIF +ENDIF + +IF(PRESENT(PGPUV)) THEN + IF(.NOT.PRESENT(PSPVOR)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') + ENDIF + IUBOUND=UBOUND(PGPUV) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_UV_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') + ENDIF + IF(IUBOUND(3) < 2) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') + ENDIF +ENDIF + +IF(PRESENT(PGP2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPSC2 HAS TO BE PRESENT WHEN PGP2 IS') + ENDIF +ENDIF +IF(IF_SC2_G > 0) THEN + IF(PRESENT(PGP2)) THEN + IUBOUND(1:3)=UBOUND(PGP2) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC2_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') + ENDIF +ENDIF +IF(IF_SC3A_G > 0) THEN + IF(PRESENT(PGP3A)) THEN + IUBOUND=UBOUND(PGP3A) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3A_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& + & IUBOUND(3),UBOUND(PSPSC3A,3) + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') + ENDIF +ENDIF +IF(IF_SC3B_G > 0) THEN + IF(PRESENT(PGP3B)) THEN + IUBOUND=UBOUND(PGP3B) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3B_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& + & IUBOUND(3),UBOUND(PSPSC3B,3) + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') + ENDIF +ENDIF +CALL GSTATS(1808,1) + +! ------------------------------------------------------------------ + +CALL EDIR_TRANS_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PMEANU,PMEANV,AUX_PROC) +IF (LHOOK) CALL DR_HOOK('EDIR_TRANS',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ +!endif INTERFACE + +END SUBROUTINE EDIR_TRANS diff --git a/src/etrans/etrans/external/edir_transad.F90 b/src/etrans/etrans/external/edir_transad.F90 new file mode 100644 index 000000000..beac97c90 --- /dev/null +++ b/src/etrans/etrans/external/edir_transad.F90 @@ -0,0 +1,493 @@ +SUBROUTINE EDIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) + +!**** *EDIR_TRANSAD* - Direct spectral transform - adjoint. + +! Purpose. +! -------- +! Interface routine for the direct spectral transform - adjoint + +!** Interface. +! ---------- +! CALL EDIR_TRANSAD(...) + +! Explicit arguments : All arguments except from PGP are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (output) +! PSPDIV(:,:) - spectral divergence (output) +! PSPSCALAR(:,:) - spectral scalarvalued fields (output) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (input) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) + +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split + +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling DIR_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. + +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A ) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 ) + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- EDIR_TRANS_CTLAD - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR, NOUT +USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & + & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA +USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE EDIR_TRANS_CTLAD_MOD ,ONLY : EDIR_TRANS_CTLAD +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANV(:) +!ifndef INTERFACE + +! Local variables +INTEGER(KIND=JPIM) :: IUBOUND(4),J +INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP +INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EDIR_TRANSAD',0,ZHOOK_HANDLE) + +CALL GSTATS(1810,0) + +! Set current resolution +CALL ESET_RESOL(KRESOL) + +! Set defaults + +IF_UV = 0 +IF_UV_G = 0 +IF_SCALARS = 0 +IF_SCALARS_G = 0 +NF_SC2 = 0 +NF_SC3A = 0 +NF_SC3B = 0 +IF_SC2_G = 0 +IF_SC3A_G = 0 +IF_SC3B_G = 0 +NPROMA = D%NGPTOT +LSCDERS=.FALSE. ! This is for use in TRLTOG which is shared with inverse transform +LVORGP=.FALSE. +LDIVGP=.FALSE. +LUVDER=.FALSE. + +! Decide requirements + +IF(PRESENT(KVSETUV)) THEN + IF_UV_G = UBOUND(KVSETUV,1) + DO J=1,IF_UV_G + IF(KVSETUV(J) > NPRTRV) THEN + WRITE(NERR,*) 'DIR_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANSAD:KVSETUV CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETUV(J) == MYSETV) THEN + IF_UV = IF_UV+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPVOR)) THEN + IF_UV = UBOUND(PSPVOR,1) + IF_UV_G = IF_UV +ENDIF + +IF(PRESENT(KVSETSC)) THEN + IF_SCALARS_G = UBOUND(KVSETSC,1) + DO J=1,IF_SCALARS_G + IF(KVSETSC(J) > NPRTRV) THEN + WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSCALAR)) THEN + IF_SCALARS = UBOUND(PSPSCALAR,1) + IF_SCALARS_G = IF_SCALARS +ENDIF + +IF(PRESENT(KVSETSC2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') + ENDIF + IF_SC2_G = UBOUND(KVSETSC2,1) + IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G + DO J=1,UBOUND(KVSETSC2,1) + IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETSC2 TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC2(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + NF_SC2 = NF_SC2+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC2)) THEN + IF_SC2_G = UBOUND(PSPSC2,1) + NF_SC2 = UBOUND(PSPSC2,1) + IF_SCALARS = IF_SCALARS+NF_SC2 + IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G +ENDIF + +IF(PRESENT(KVSETSC3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') + ENDIF + IF_SC3A_G = UBOUND(KVSETSC3A,1) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) + DO J=1,UBOUND(KVSETSC3A,1) + IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3A(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,3) + NF_SC3A = NF_SC3A+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3A)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,1)*UBOUND(PSPSC3A,3) + IF_SC3A_G = UBOUND(PSPSC3A,1) + IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) + NF_SC3A = UBOUND(PSPSC3A,1) +ENDIF + +IF(PRESENT(KVSETSC3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') + ENDIF + IF_SC3B_G = UBOUND(KVSETSC3B,1) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) + DO J=1,UBOUND(KVSETSC3B,1) + IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN + WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV + CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3B(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,3) + NF_SC3B = NF_SC3B+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3B)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,1)*UBOUND(PSPSC3B,3) + IF_SC3B_G = UBOUND(PSPSC3B,1) + IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) + NF_SC3B = UBOUND(PSPSC3B,1) +ENDIF + +IF(PRESENT(KPROMA)) THEN + NPROMA = KPROMA +ENDIF + +! Compute derived variables + +NGPBLKS = (D%NGPTOT-1)/NPROMA+1 + +IF_FS = 2*IF_UV + IF_SCALARS + +IF_GP = 2*IF_UV_G+IF_SCALARS_G + +! Consistency checks + +IF (IF_UV > 0) THEN + IF(.NOT. PRESENT(PSPVOR) ) THEN + CALL ABORT_TRANS('DIR_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING') + ENDIF + IF(UBOUND(PSPVOR,1) < IF_UV) THEN + WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& + & UBOUND(PSPVOR,1),IF_UV + CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR TOO SHORT') + ENDIF + IF(.NOT. PRESENT(PSPDIV) ) THEN + CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR PRESENT BUT PSPDIV MISSING') + ENDIF + IF(UBOUND(PSPDIV,1) /= IF_UV) THEN + WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& + & UBOUND(PSPDIV,1),IF_UV + CALL ABORT_TRANS('DIR_TRANSAD : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') + ENDIF +ENDIF + +IF (IF_SCALARS > 0) THEN + IF(PRESENT(PSPSCALAR)) THEN + IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN + WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& + & UBOUND(PSPSCALAR,1),IF_SCALARS + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') + ENDIF + IF(PRESENT(PSPSC3A))THEN + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC3B))THEN + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC2))THEN + CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') + ENDIF + ENDIF +ENDIF + +IF(NPRTRV >1) THEN + IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN + WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& + & NPRTRV,IF_UV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSCALAR) .AND. .NOT. PRESENT(KVSETSC)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSCALAR) AND NOT PRESENT(KVSETSC)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC2) .AND. .NOT. PRESENT(KVSETSC2)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC2) AND NOT PRESENT(KVSETSC2)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3A) .AND. .NOT. PRESENT(KVSETSC3A)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3A) AND NOT PRESENT(KVSETSC3A)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3B) .AND. .NOT. PRESENT(KVSETSC3B)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3B) AND NOT PRESENT(KVSETSC3B)',& + & NPRTRV + CALL ABORT_TRANS('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF +ENDIF + +IF(PRESENT(PGP)) THEN + IUBOUND(1:3)=UBOUND(PGP) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(2) < IF_GP) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP + CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') + ENDIF +ENDIF + +IF(PRESENT(PGPUV)) THEN + IF(.NOT.PRESENT(PSPVOR)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') + ENDIF + IUBOUND=UBOUND(PGPUV) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_UV_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') + ENDIF + IF(IUBOUND(3) < 2) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') + ENDIF +ENDIF + +IF(PRESENT(PGP2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPSC2 HAS TO BE PRESENT WHEN PGP2 IS') + ENDIF +ENDIF +IF(IF_SC2_G > 0) THEN + IF(PRESENT(PGP2)) THEN + IUBOUND(1:3)=UBOUND(PGP2) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC2_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') + ENDIF +ENDIF +IF(IF_SC3A_G > 0) THEN + IF(PRESENT(PGP3A)) THEN + IUBOUND=UBOUND(PGP3A) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3A_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& + & IUBOUND(3),UBOUND(PSPSC3A,3) + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') + ENDIF +ENDIF +IF(IF_SC3B_G > 0) THEN + IF(PRESENT(PGP3B)) THEN + IUBOUND=UBOUND(PGP3B) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3B_G) THEN + WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G + CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN + WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& + & IUBOUND(3),UBOUND(PSPSC3B,3) + CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') + ENDIF +ENDIF +CALL GSTATS(1810,1) + +! Perform transform + +CALL EDIR_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PMEANU,PMEANV) +IF (LHOOK) CALL DR_HOOK('EDIR_TRANSAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ +!endif INTERFACE + +END SUBROUTINE EDIR_TRANSAD + diff --git a/src/etrans/etrans/external/edist_grid.F90 b/src/etrans/etrans/external/edist_grid.F90 new file mode 100644 index 000000000..78559288b --- /dev/null +++ b/src/etrans/etrans/external/edist_grid.F90 @@ -0,0 +1,136 @@ +SUBROUTINE EDIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) + +!**** *EDIST_GRID* - Distribute global gridpoint array among processors + +! Purpose. +! -------- +! Interface routine for distributing gridpoint array + +!** Interface. +! ---------- +! CALL EDIST_GRID(...) + +! Explicit arguments : +! -------------------- +! PGPG(:,:) - Global spectral array +! KFDISTG - Global number of fields to be distributed +! KPROMA - required blocking factor for gridpoint input +! KFROM(:) - Processor resposible for distributing each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:) - Local spectral array + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- DIST_GRID_CTL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! P.Marguinaud 10-Oct-2014 Add KSORT argument + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR, NOUT +!USE TPM_DIM +USE TPM_DISTR ,ONLY : D, MYPROC, NPROC + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE DIST_GRID_CTL_MOD ,ONLY : DIST_GRID_CTL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG +INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) +!ifndef INTERFACE + +INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Set current resolution +IF (LHOOK) CALL DR_HOOK('EDIST_GRID',0,ZHOOK_HANDLE) +CALL ESET_RESOL(KRESOL) + +IPROMA = D%NGPTOT +IF(PRESENT(KPROMA)) THEN + IPROMA = KPROMA +ENDIF +IGPBLKS = (D%NGPTOT-1)/IPROMA+1 + +IF(UBOUND(KFROM,1) < KFDISTG) THEN + CALL ABORT_TRANS('EDIST_GRID: KFROM TOO SHORT!') +ENDIF +IFSEND = 0 +DO J=1,KFDISTG + IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN + WRITE(NERR,*) 'EDIST_GRID:ILLEGAL KFROM VALUE',KFROM(J),J + CALL ABORT_TRANS('EDIST_GRID:ILLEGAL KFROM VALUE') + ENDIF + IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 +ENDDO + +IUBOUND=UBOUND(PGP) +IF(IUBOUND(1) < IPROMA) THEN + WRITE(NOUT,*)'EDIST_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA + CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGP TOO SMALL ') +ENDIF +IF(IUBOUND(2) < KFDISTG) THEN + WRITE(NOUT,*)'EDIST_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFDISTG + CALL ABORT_TRANS('EDIST_GRID:SECOND DIMENSION OF PGP TOO SMALL ') +ENDIF +IF(IUBOUND(3) < IGPBLKS) THEN + WRITE(NOUT,*)'EDIST_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS + CALL ABORT_TRANS('EDIST_GRID:THIRD DIMENSION OF PGP TOO SMALL ') +ENDIF + +IF(IFSEND > 0) THEN + IF(.NOT.PRESENT(PGPG)) THEN + CALL ABORT_TRANS('EDIST_GRID:PGPG MISSING') + ENDIF + IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN + CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') + ENDIF + IF(UBOUND(PGPG,2) < IFSEND) THEN + CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') + ENDIF +ENDIF + +IF (PRESENT (KSORT)) THEN + IF (UBOUND (KSORT, 1) /= UBOUND (PGP, 2)) THEN + CALL ABORT_TRANS('EDIST_GRID: DIMENSION MISMATCH KSORT, PGP') + ENDIF +ENDIF + +CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP,KSORT) +IF (LHOOK) CALL DR_HOOK('EDIST_GRID',1,ZHOOK_HANDLE) + +!endif INTERFACE + +! ------------------------------------------------------------------ + +END SUBROUTINE EDIST_GRID + diff --git a/src/etrans/etrans/external/edist_spec.F90 b/src/etrans/etrans/external/edist_spec.F90 new file mode 100644 index 000000000..eeaa512ce --- /dev/null +++ b/src/etrans/etrans/external/edist_spec.F90 @@ -0,0 +1,195 @@ +SUBROUTINE EDIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& + & LDIM1_IS_FLD,KSORT) + +!**** *EDIST_SPEC* - Distribute global spectral array among processors + +! Purpose. +! -------- +! Interface routine for distributing spectral array + +!** Interface. +! ---------- +! CALL EDIST__SPEC(...) + +! Explicit arguments : +! -------------------- +! PSPECG(:,:) - Global spectral array +! KFDISTG - Global number of fields to be distributed +! KFROM(:) - Processor resposible for distributing each field +! KVSET(:) - "B-Set" for each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PSPEC(:,:) - Local spectral array + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- DIST_SPEC_CONTROL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! P.Marguinaud 10-Oct-2014 Add KSORT argument (change the order of fields) + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR +USE TPM_DIM ,ONLY : R +USE TPMALD_DIM ,ONLY : RALD +USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC +USE TPMALD_DISTR ,ONLY : DALD + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE DIST_SPEC_CONTROL_MOD ,ONLY : DIST_SPEC_CONTROL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPECG(:,:) +INTEGER(KIND=JPIM),INTENT(IN) :: KFDISTG +INTEGER(KIND=JPIM),INTENT(IN) :: KFROM(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSET(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +LOGICAL ,OPTIONAL,INTENT(IN) :: LDIM1_IS_FLD +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPEC(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KSORT (:) +!ifndef INTERFACE + +INTEGER(KIND=JPIM) :: IVSET(KFDISTG) +INTEGER(KIND=JPIM) :: IFSEND,IFRECV,J, IFLD, ICOEFF +INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G, ISPEC2MX +INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) +INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) +INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) +INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) +INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) +INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) +LOGICAL :: LLDIM1_IS_FLD +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +! Set current resolution +IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',0,ZHOOK_HANDLE) +CALL ESET_RESOL(KRESOL) + +LLDIM1_IS_FLD=.TRUE. +IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD=LDIM1_IS_FLD +IF(LLDIM1_IS_FLD) THEN + IFLD=1 + ICOEFF=2 +ELSE + IFLD=2 + ICOEFF=1 +ENDIF + +ISMAX = RALD%NMSMAX +ALLOCATE(IDIM0G(0:ISMAX)) +ALLOCATE(IALLMS(ISMAX+1)) +ALLOCATE(IKN(0:ISMAX)) +ISPEC2 = D%NSPEC2 +ISPEC2_G = R%NSPEC2_G +IPOSSP(:) = D%NPOSSP(:) +IDIM0G(:) = D%NDIM0G(:) +ISPEC2MX = D%NSPEC2MX +IUMPP(:) = D%NUMPP(:) +IALLMS(:) = D%NALLMS(:) +IPTRMS(:) = D%NPTRMS(:) +DO J=0,ISMAX + IKN(J)=2*DALD%NCPL2M(J) +ENDDO + +IF(UBOUND(KFROM,1) < KFDISTG) THEN + CALL ABORT_TRANS('EDIST_SPEC: KFROM TOO SHORT!') +ENDIF + +IFSEND = 0 +IFRECV = 0 + +DO J=1,KFDISTG + IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN + WRITE(NERR,*) 'EDIST_SPEC:ILLEGAL KFROM VALUE',KFROM(J),J + CALL ABORT_TRANS('EDIST_SPEC:ILLEGAL KFROM VALUE') + ENDIF + IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 +ENDDO + +IF(IFSEND > 0) THEN + IF(.NOT.PRESENT(PSPECG)) THEN + CALL ABORT_TRANS('EDIST_SPEC:PSPECG MISSING') + ENDIF + IF(UBOUND(PSPECG,IFLD) < IFSEND) THEN + WRITE(NERR,*)'EDIST_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFSEND + CALL ABORT_TRANS('EDIST_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') + ENDIF + IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN + WRITE(NERR,*)'EDIST_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G + CALL ABORT_TRANS('EDIST_SPEC: COEFF DIMENSION OF PSPECG TOO SMALL') + ENDIF +ENDIF + +IF(PRESENT(KVSET)) THEN + IF(UBOUND(KVSET,1) < KFDISTG) THEN + CALL ABORT_TRANS('EDIST_SPEC: KVSET TOO SHORT!') + ENDIF + DO J=1,KFDISTG + IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN + WRITE(NERR,*) 'EDIST_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV + CALL ABORT_TRANS('EDIST_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSET(J) == MYSETV) THEN + IFRECV = IFRECV+1 + ENDIF + ENDDO + IVSET(:) = KVSET(1:KFDISTG) +ELSE + IFRECV = KFDISTG + IVSET(:) = MYSETV +ENDIF + +IF(IFRECV > 0 ) THEN + IF(.NOT.PRESENT(PSPEC)) THEN + CALL ABORT_TRANS('EDIST_SPEC: FIELDS TO RECEIVE AND PSPEC NOT PRESENT') + ENDIF + IF(UBOUND(PSPEC,IFLD) < IFRECV) THEN + CALL ABORT_TRANS('EDIST_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') + ENDIF + IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN + CALL ABORT_TRANS('EDIST_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') + ENDIF +ENDIF + +IF (PRESENT (KSORT)) THEN + IF (.NOT. PRESENT (PSPEC)) THEN + CALL ABORT_TRANS('EDIST_SPEC: KSORT REQUIRES PSPEC') + ENDIF + IF (UBOUND (KSORT, 1) /= UBOUND (PSPEC, IFLD)) THEN + CALL ABORT_TRANS('EDIST_SPEC: DIMENSION MISMATCH KSORT, PSPEC') + ENDIF +ENDIF + +CALL DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,IVSET,PSPEC,LLDIM1_IS_FLD,& + & ISMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,KSORT) +DEALLOCATE(IDIM0G) +IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',1,ZHOOK_HANDLE) + +!endif INTERFACE + +! ------------------------------------------------------------------ + +END SUBROUTINE EDIST_SPEC + diff --git a/src/etrans/etrans/external/egath_grid.F90 b/src/etrans/etrans/external/egath_grid.F90 new file mode 100644 index 000000000..05455b522 --- /dev/null +++ b/src/etrans/etrans/external/egath_grid.F90 @@ -0,0 +1,129 @@ +SUBROUTINE EGATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) + +!**** *EGATH_GRID* - Gather global gridpoint array from processors + +! Purpose. +! -------- +! Interface routine for gathering gripoint array + +!** Interface. +! ---------- +! CALL EGATH_GRID(...) + +! Explicit arguments : +! -------------------- +! PGPG(:,:) - Global gridpoint array +! KFGATHG - Global number of fields to be gathered +! KPROMA - blocking factor for gridpoint input +! KTO(:) - Processor responsible for gathering each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - Local spectral array + +! Method. +! ------- + +! Externals. SET_RESOL - set resolution +! ---------- GATH_GRID_CTL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR, NOUT +!USE TPM_DIM +USE TPM_DISTR ,ONLY : D, MYPROC, NPROC + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE GATH_GRID_CTL_MOD ,ONLY : GATH_GRID_CTL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPG(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM),INTENT(IN) :: KFGATHG +INTEGER(KIND=JPIM),INTENT(IN) :: KTO(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) +!ifndef INTERFACE + +INTEGER(KIND=JPIM) :: IFRECV,J,IUBOUND(3),IPROMA,IGPBLKS +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Set current resolution +IF (LHOOK) CALL DR_HOOK('EGATH_GRID',0,ZHOOK_HANDLE) +CALL ESET_RESOL(KRESOL) + +IPROMA = D%NGPTOT +IF(PRESENT(KPROMA)) THEN + IPROMA = KPROMA +ENDIF +IGPBLKS = (D%NGPTOT-1)/IPROMA+1 + +IF(UBOUND(KTO,1) < KFGATHG) THEN + CALL ABORT_TRANS('GATH_GRID: KTO TOO SHORT!') +ENDIF + +IFRECV = 0 +DO J=1,KFGATHG + IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN + WRITE(NERR,*) 'GATH_GRID:ILLEGAL KTO VALUE',KTO(J),J + CALL ABORT_TRANS('GATH_GRID:ILLEGAL KTO VALUE') + ENDIF + IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 +ENDDO + +IUBOUND=UBOUND(PGP) +IF(IUBOUND(1) < IPROMA) THEN + WRITE(NOUT,*)'GATH_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA + CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGP TOO SMALL ') +ENDIF +IF(IUBOUND(2) < KFGATHG) THEN + WRITE(NOUT,*)'GATH_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFGATHG + CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGP TOO SMALL ') +ENDIF +IF(IUBOUND(3) < IGPBLKS) THEN + WRITE(NOUT,*)'GATH_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS + CALL ABORT_TRANS('GATH_GRID:THIRD DIMENSION OF PGP TOO SMALL ') +ENDIF + +IF(IFRECV > 0) THEN + IF(.NOT.PRESENT(PGPG)) THEN + CALL ABORT_TRANS('GATH_GRID:PGPG MISSING') + ENDIF + IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN + CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGPG TOO SMALL') + ENDIF + IF(UBOUND(PGPG,2) < IFRECV) THEN + CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGPG TOO SMALL') + ENDIF +ENDIF + +CALL GATH_GRID_CTL(PGPG,KFGATHG,IPROMA,KTO,PGP) +IF (LHOOK) CALL DR_HOOK('EGATH_GRID',1,ZHOOK_HANDLE) + +!endif INTERFACE + +! ------------------------------------------------------------------ + +END SUBROUTINE EGATH_GRID + diff --git a/src/etrans/etrans/external/egath_spec.F90 b/src/etrans/etrans/external/egath_spec.F90 new file mode 100644 index 000000000..4b2bde0c3 --- /dev/null +++ b/src/etrans/etrans/external/egath_spec.F90 @@ -0,0 +1,203 @@ +SUBROUTINE EGATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,KMSMAX,LDZA0IP) + +!**** *EGATH_SPEC* - Gather global spectral array from processors + +! Purpose. +! -------- +! Interface routine for gathering spectral array + +!** Interface. +! ---------- +! CALL EGATH_SPEC(...) + +! Explicit arguments : +! -------------------- +! PSPECG(:,:) - Global spectral array +! KFGATHG - Global number of fields to be gathered +! KTO(:) - Processor responsible for gathering each field +! KVSET(:) - "B-Set" for each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PSPEC(:,:) - Local spectral array +! LDZA0IP - Set to zero imaginary part of first coefficients + +! +! Method. +! ------- + +! Externals. SET_RESOL - set resolution +! ---------- GATH_SPEC_CONTROL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! Modified 03-09-30 Y. Seity, bug correction IFSEND=0 +! R. El Khatib 23-Oct-2012 Monkey business +! P.Marguinaud 10-Oct-2013 Add an option to set (or not) first +! coefficients imaginary part to zero +! R. El Khatib 01-Dec-2020 Merge egath_spec_control and gath_spec_control +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR +USE TPM_DIM ,ONLY : R +USE TPMALD_DIM ,ONLY : RALD +USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC +USE TPMALD_DISTR + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE GATH_SPEC_CONTROL_MOD ,ONLY : GATH_SPEC_CONTROL + +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG +INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) +LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMSMAX +LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP + +!ifndef INTERFACE + +INTEGER(KIND=JPIM) :: IVSET(KFGATHG) +INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J +INTEGER(KIND=JPIM) :: IFLD,ICOEFF +INTEGER(KIND=JPIM) :: ISMAX, IMSMAX, ISPEC2, ISPEC2_G,ISPEC2MX +INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) +INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) +INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) +INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) +INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) +INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) +LOGICAL :: LLDIM1_IS_FLD +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',0,ZHOOK_HANDLE) +! Set current resolution +CALL ESET_RESOL(KRESOL) + +LLDIM1_IS_FLD = .TRUE. +IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD + +IF(LLDIM1_IS_FLD) THEN + IFLD = 1 + ICOEFF = 2 +ELSE + IFLD = 2 + ICOEFF = 1 +ENDIF +IF(UBOUND(KTO,1) < KFGATHG) THEN + CALL ABORT_TRANS('EGATH_SPEC: KTO TOO SHORT!') +ENDIF + +ISMAX = R%NSMAX +IMSMAX = RALD%NMSMAX +IF(PRESENT(KSMAX)) ISMAX = KSMAX +IF(PRESENT(KMSMAX)) IMSMAX = KMSMAX +ALLOCATE(IDIM0G(0:IMSMAX)) +ALLOCATE(IALLMS(IMSMAX+1)) +ALLOCATE(IKN(0:IMSMAX)) +IF(IMSMAX /= RALD%NMSMAX .OR. ISMAX /= R%NSMAX) THEN + CALL ABORT_TRANS('EGATH_SPEC:TRUNCATION CHANGE NOT YET CODED') +ELSE + ISPEC2 = D%NSPEC2 + ISPEC2_G = R%NSPEC2_G + IPOSSP(:) = D%NPOSSP(:) + IDIM0G(:) = D%NDIM0G(:) + ISPEC2MX = D%NSPEC2MX + IUMPP(:) = D%NUMPP(:) + IALLMS(:) = D%NALLMS(:) + IPTRMS(:) = D%NPTRMS(:) + DO J=0,IMSMAX + IKN(J)=2*DALD%NCPL2M(J) + ENDDO +ENDIF + +IFSEND = 0 +IFRECV = 0 +DO J=1,KFGATHG + IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN + WRITE(NERR,*) 'EGATH_SPEC:ILLEGAL KTO VALUE',KTO(J),J + CALL ABORT_TRANS('EGATH_SPEC:ILLEGAL KTO VALUE') + ENDIF + IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 +ENDDO + +IF(IFRECV > 0) THEN + IF(.NOT.PRESENT(PSPECG)) THEN + CALL ABORT_TRANS('EGATH_SPEC:PSPECG MISSING') + ENDIF + IF(UBOUND(PSPECG,IFLD) < IFRECV) THEN + WRITE(NERR,*) 'EGATH_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFRECV + CALL ABORT_TRANS('EGATH_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') + ENDIF + IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN + WRITE(NERR,*) 'EGATH_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G + CALL ABORT_TRANS('EGATH_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') + ENDIF +ENDIF + +IF(PRESENT(KVSET)) THEN + IF(UBOUND(KVSET,1) < KFGATHG) THEN + CALL ABORT_TRANS('EGATH_SPEC: KVSET TOO SHORT!') + ENDIF + DO J=1,KFGATHG + IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN + WRITE(NERR,*) 'EGATH_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV + CALL ABORT_TRANS('EGATH_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSET(J) == MYSETV) THEN + IFSEND = IFSEND+1 + ENDIF + ENDDO + IVSET(:) = KVSET(1:KFGATHG) +ELSEIF(NPRTRV > 1) THEN + WRITE(NERR,*) 'EGATH_SPEC:KVSET MISSING, NPRTRV ',NPRTRV + CALL ABORT_TRANS('EGATH_SPEC:KVSET MISSING, NPRTRV > 1') +ELSE + IFSEND = KFGATHG + IVSET(:) = 1 +ENDIF + +IF(IFSEND > 0 ) THEN + IF(.NOT.PRESENT(PSPEC)) THEN + CALL ABORT_TRANS('EGATH_SPEC: FIELDS TO RECIEVE AND PSPEC NOT PRESENT') + ENDIF + IF(UBOUND(PSPEC,IFLD) < IFSEND) THEN + CALL ABORT_TRANS('EGATH_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') + ENDIF + IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN + CALL ABORT_TRANS('EGATH_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') + ENDIF +ENDIF + +CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,& + & IMSMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,LDZA0IP) +DEALLOCATE(IDIM0G) + +IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',1,ZHOOK_HANDLE) +!endif INTERFACE + +! ------------------------------------------------------------------ + +END SUBROUTINE EGATH_SPEC diff --git a/src/etrans/etrans/external/egpnorm_trans.F90 b/src/etrans/etrans/external/egpnorm_trans.F90 new file mode 100644 index 000000000..3c2b32906 --- /dev/null +++ b/src/etrans/etrans/external/egpnorm_trans.F90 @@ -0,0 +1,93 @@ +SUBROUTINE EGPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) + + +!**** *EGPNORM_TRANS* - calculate grid-point norms + +! Purpose. +! -------- +! calculate grid-point norms + +!** Interface. +! ---------- +! CALL EGPNORM_TRANS(...) + +! Explicit arguments : +! -------------------- +! PGP(:,:,:) - gridpoint fields (input) +! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where +! NPROMA is the blocking factor, KFIELDS the total number +! of fields and NGPBLKS the number of NPROMA blocks. +! KFIELDS - number of fields (input) +! (these do not have to be just levels) +! KPROMA - required blocking factor (input) +! PAVE - average (output) +! PMIN - minimum (input/output) +! PMAX - maximum (input/output) +! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX +! KRESOL - resolution tag (optional) +! default assumes first defined resolution +! + +! Author. +! ------- +! George Mozdzynski *ECMWF* + +! Modifications. +! -------------- +! Original : 19th Sept 2008 +! R. El Khatib 07-08-2009 Optimisation directive for NEC +! R. El Khatib 16-Sep-2019 merge with global model code +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD + +!ifndef INTERFACE + +USE TPM_DIM ,ONLY : R +USE TPM_GEOMETRY ,ONLY : G +USE TPM_DIM ,ONLY : R +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE GPNORM_TRANS_CTL_MOD, ONLY : GPNORM_TRANS_CTL +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PMIN(:) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PMAX(:) +INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS +INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA +LOGICAL ,INTENT(IN) :: LDAVE_ONLY +INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL + +!ifndef INTERFACE + +! Local variables +INTEGER(KIND=JPIM) :: JGL +REAL(KIND=JPRB) :: ZW(R%NDGL) + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('EGPNORM_TRANS',0,ZHOOK_HANDLE) + +! Set current resolution +CALL ESET_RESOL(KRESOL) + +DO JGL=1,R%NDGL + ZW(1:)=1._JPRB/G%NLOEN(JGL) +ENDDO +CALL GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,ZW(1:R%NDGL)) + +IF (LHOOK) CALL DR_HOOK('EGPNORM_TRANS',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +!endif INTERFACE + + +END SUBROUTINE EGPNORM_TRANS diff --git a/src/etrans/etrans/external/einv_trans.F90 b/src/etrans/etrans/external/einv_trans.F90 new file mode 100644 index 000000000..25f47c07a --- /dev/null +++ b/src/etrans/etrans/external/einv_trans.F90 @@ -0,0 +1,607 @@ +SUBROUTINE EINV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & FSPGL_PROC,& + & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) + +!**** *EINV_TRANS* - Inverse spectral transform. + +! Purpose. +! -------- +! Interface routine for the inverse spectral transform + +!** Interface. +! ---------- +! CALL EINV_TRANS(...) + +! Explicit arguments : All arguments are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition +! LDSCDERS - indicating if derivatives of scalar variables are req. +! LDVORGP - indicating if grid-point vorticity is req. +! LDDIVGP - indicating if grid-point divergence is req. +! LDUVDER - indicating if E-W derivatives of u and v are req. +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (output) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! vorticity : IF_UV_G fields (if psvor present and LDVORGP) +! divergence : IF_UV_G fields (if psvor present and LDDIVGP) +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) +! N-S derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) +! E-W derivative of u : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of v : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) + +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split + +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling INV_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. + +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v,vor,div ...) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A if no derivatives, 3 times that with der.) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B if no derivatives, 3 times that with der.) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 if no derivatives, 3 times that with der.) +! Method. +! ------- + +! Externals. SET_RESOL - set resolution +! ---------- LTINV_CTL - control of Legendre transform +! FTINV_CTL - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields +! and derivatives (IF_SCALARS_G) +! Y. Seity and G. Radnoti : 03-09-29 : phasing for AL27 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR, NOUT, NPROMATR +!USE TPM_DIM +USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & + & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA +USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV +!USE TPM_GEOMETRY +!USE TPM_FIELDS +!USE TPM_FFT + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE EINV_TRANS_CTL_MOD ,ONLY : EINV_TRANS_CTL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) +LOGICAL ,OPTIONAL,INTENT(IN) :: LDSCDERS +LOGICAL ,OPTIONAL,INTENT(IN) :: LDVORGP +LOGICAL ,OPTIONAL,INTENT(IN) :: LDDIVGP +LOGICAL ,OPTIONAL,INTENT(IN) :: LDUVDER +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMEANV(:) +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC +!ifndef INTERFACE + +! Local varaibles +INTEGER(KIND=JPIM) :: IUBOUND(4),J +INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP,IF_OUT_LT +INTEGER(KIND=JPIM) :: IF_SCDERS,IF_UV_PAR +INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G2,IF_SC3A_G3,IF_SC3B_G2,IF_SC3B_G3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EINV_TRANS',0,ZHOOK_HANDLE) +CALL GSTATS(1807,0) + +! Set current resolution +CALL ESET_RESOL(KRESOL) + +! Set defaults + +LVORGP = .FALSE. +LDIVGP = .FALSE. +LUVDER = .FALSE. +IF_UV = 0 +IF_UV_G = 0 +IF_UV_PAR = 0 +IF_SCALARS = 0 +IF_SCALARS_G = 0 +IF_SCDERS = 0 +NF_SC2 = 0 +NF_SC3A = 0 +NF_SC3B = 0 +IF_SC2_G = 0 +IF_SC3A_G2 = 0 +IF_SC3B_G2 = 0 +IF_SC3A_G3 = 0 +IF_SC3B_G3 = 0 +NPROMA = D%NGPTOT +LSCDERS = .FALSE. + +! Decide requirements + +IF(PRESENT(KVSETUV)) THEN + IF_UV_G = UBOUND(KVSETUV,1) + IF_UV_PAR = 2 + DO J=1,IF_UV_G + IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN + WRITE(NERR,*) 'INV_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV + CALL ABORT_TRANS('INV_TRANS:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETUV(J) == MYSETV) THEN + IF_UV = IF_UV+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPVOR)) THEN + IF_UV = UBOUND(PSPVOR,1) + IF_UV_G = IF_UV + IF_UV_PAR = 2 +ENDIF + +IF(PRESENT(KVSETSC)) THEN + IF(.NOT. PRESENT(PSPSCALAR) ) THEN + CALL ABORT_TRANS('INV_TRANS : KVSETSC PRESENT BUT PSPSCALAR MISSING') + ENDIF + IF_SCALARS_G = UBOUND(KVSETSC,1) + DO J=1,IF_SCALARS_G + IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN + WRITE(NERR,*) 'INV_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV + CALL ABORT_TRANS('INV_TRANS:KVSETSC TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSCALAR)) THEN + IF_SCALARS = UBOUND(PSPSCALAR,1) + IF_SCALARS_G = IF_SCALARS +ENDIF + +IF(PRESENT(KVSETSC2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('INV_TRANS:KVSETSC2 BUT NOT PSPSC2') + ENDIF + IF_SC2_G = UBOUND(KVSETSC2,1) + IF_SCALARS_G = IF_SCALARS_G+UBOUND(KVSETSC2,1) + DO J=1,UBOUND(KVSETSC2,1) + IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN + WRITE(NERR,*) 'INV_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV + CALL ABORT_TRANS('INV_TRANS:KVSETSC2 TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC2(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + NF_SC2 = NF_SC2+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC2)) THEN + IF_SC2_G = UBOUND(PSPSC2,1) + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC2,1) + IF_SCALARS_G = IF_SCALARS_G +UBOUND(PSPSC2,1) + NF_SC2 = UBOUND(PSPSC2,1) +ENDIF + +IF(PRESENT(KVSETSC3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('INV_TRANS:KVSETSC3A BUT NOT PSPSC3A') + ENDIF + IF_SC3A_G2 = UBOUND(KVSETSC3A,1) + IF_SC3A_G3 = UBOUND(PSPSC3A,3) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G2*IF_SC3A_G3 + DO J=1,UBOUND(KVSETSC3A,1) + IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN + WRITE(NERR,*) 'INV_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV + CALL ABORT_TRANS& + & ('INV_TRANS:KVSETSC3A TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3A(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,3) + NF_SC3A = NF_SC3A+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3A)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,1)*UBOUND(PSPSC3A,3) + IF_SC3A_G2 = UBOUND(PSPSC3A,1) + IF_SC3A_G3 = UBOUND(PSPSC3A,3) + IF_SCALARS_G = IF_SCALARS_G + IF_SC3A_G2*IF_SC3A_G3 + NF_SC3A = UBOUND(PSPSC3A,1) +ENDIF + +IF(PRESENT(KVSETSC3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('INV_TRANS:KVSETSC3B BUT NOT PSPSC3B') + ENDIF + IF_SC3B_G2 = UBOUND(KVSETSC3B,1) + IF_SC3B_G3 = UBOUND(PSPSC3B,3) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G2*IF_SC3B_G3 + DO J=1,UBOUND(KVSETSC3B,1) + IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN + WRITE(NERR,*) 'INV_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV + CALL ABORT_TRANS('INV_TRANS:KVSETSC3B TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3B(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,3) + NF_SC3B = NF_SC3B+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3B)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,1)*UBOUND(PSPSC3B,3) + IF_SC3B_G2 = UBOUND(PSPSC3B,1) + IF_SC3B_G3 = UBOUND(PSPSC3B,3) + IF_SCALARS_G = IF_SCALARS_G + IF_SC3B_G2*IF_SC3B_G3 + NF_SC3B = UBOUND(PSPSC3B,1) +ENDIF + +IF (IF_SCALARS_G > 0 ) THEN + IF(PRESENT(LDSCDERS)) THEN + LSCDERS = LDSCDERS + IF (LSCDERS) IF_SCDERS = IF_SCALARS + ENDIF +ENDIF + +IF(PRESENT(KPROMA)) THEN + NPROMA = KPROMA +ENDIF + +IF(PRESENT(LDVORGP)) THEN + LVORGP = LDVORGP +ENDIF + +IF(PRESENT(LDDIVGP)) THEN + LDIVGP = LDDIVGP +ENDIF + +IF(PRESENT(LDUVDER)) THEN + LUVDER = LDUVDER +ENDIF + +! Compute derived variables + +IF(LVORGP) LDIVGP = .TRUE. + +NGPBLKS = (D%NGPTOT-1)/NPROMA+1 + +IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS + +IF(IF_UV > 0 .AND. LVORGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV +ENDIF +IF(IF_UV > 0 .AND. LDIVGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV +ENDIF +IF_FS = IF_OUT_LT+IF_SCDERS +IF(IF_UV > 0 .AND. LUVDER) THEN + IF_FS = IF_FS+2*IF_UV +ENDIF + +IF_GP = 2*IF_UV_G+IF_SCALARS_G +IF(LSCDERS) THEN + IF_GP = IF_GP+2*IF_SCALARS_G + IF_SC2_G = IF_SC2_G*3 + IF_SC3A_G3 = IF_SC3A_G3*3 + IF_SC3B_G3 = IF_SC3B_G3*3 +ENDIF +IF(IF_UV_G > 0 .AND. LVORGP) THEN + IF_GP = IF_GP+IF_UV_G + IF_UV_PAR = IF_UV_PAR+1 +ENDIF +IF(IF_UV_G > 0 .AND. LDIVGP) THEN + IF_GP = IF_GP+IF_UV_G + IF_UV_PAR = IF_UV_PAR+1 +ENDIF +IF(IF_UV_G > 0 .AND. LUVDER) THEN + IF_GP = IF_GP+2*IF_UV_G + IF_UV_PAR = IF_UV_PAR+2 +ENDIF + +! Consistency checks + +IF (IF_UV > 0) THEN + IF(.NOT. PRESENT(PSPVOR) ) THEN + CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPVOR MISSING') + ENDIF + IF(UBOUND(PSPVOR,1) < IF_UV) THEN + WRITE(NERR,*)'INV_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV + CALL ABORT_TRANS('INV_TRANS : PSPVOR TOO SHORT') + ENDIF + IF(.NOT. PRESENT(PSPDIV) ) THEN + CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPDIV MISSING') + ENDIF + IF(UBOUND(PSPDIV,1) < IF_UV) THEN + WRITE(NERR,*)'INV_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV + CALL ABORT_TRANS('INV_TRANS : PSPDIV TOO SHORT') + ENDIF +ENDIF + +IF (IF_SCALARS > 0) THEN + IF(PRESENT(PSPSCALAR)) THEN + IF(PRESENT(PSPSC3A))THEN + CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC3B))THEN + CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC2))THEN + CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') + ENDIF + IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN + WRITE(NERR,*)'INV_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& + & UBOUND(PSPSCALAR,1),IF_SCALARS + CALL ABORT_TRANS('INV_TRANS : PSPSCALAR TOO SHORT') + ENDIF + ELSEIF(PRESENT(PSPSC3A)) THEN + ENDIF +ENDIF + +IF(IF_UV_G == 0) THEN + LUVDER = .FALSE. +ENDIF + +IF(NPRTRV >1) THEN + IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN + WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& + & NPRTRV,IF_UV + CALL ABORT_TRANS('INV_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSCALAR) .AND. .NOT. PRESENT(KVSETSC)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSCALAR) AND NOT PRESENT(KVSETSC)',& + & NPRTRV + CALL ABORT_TRANS('INV_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC2) .AND. .NOT. PRESENT(KVSETSC2)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC2) AND NOT PRESENT(KVSETSC2)',& + & NPRTRV + CALL ABORT_TRANS('INV_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3A) .AND. .NOT. PRESENT(KVSETSC3A)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3A) AND NOT PRESENT(KVSETSC3A)',& + & NPRTRV + CALL ABORT_TRANS('INV_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3B) .AND. .NOT. PRESENT(KVSETSC3B)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3B) AND NOT PRESENT(KVSETSC3B)',& + & NPRTRV + CALL ABORT_TRANS('INV_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF +ENDIF + +IF(PRESENT(PGP)) THEN + IF(PRESENT(PGPUV)) THEN + CALL ABORT_TRANS('INV_TRANS:PGP AND PGPUV CAN NOT BOTH BE PRESENT') + ENDIF + IF(PRESENT(PGP3A)) THEN + CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3A CAN NOT BOTH BE PRESENT') + ENDIF + IF(PRESENT(PGP3B)) THEN + CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3B CAN NOT BOTH BE PRESENT') + ENDIF + IF(PRESENT(PGP2)) THEN + CALL ABORT_TRANS('INV_TRANS:PGP AND PGP2 CAN NOT BOTH BE PRESENT') + ENDIF + IUBOUND(1:3)=UBOUND(PGP) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(2) < IF_GP) THEN + WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP + WRITE(NOUT,*)'IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER ',& + & IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER + CALL ABORT_TRANS('INV_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') + ENDIF +ELSE + IF(NPROMATR > 0 .AND. 2*IF_UV_G+IF_SCALARS_G > NPROMATR) THEN + CALL ABORT_TRANS('INV_TRANS:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') + ENDIF +ENDIF + +IF(PRESENT(PGPUV)) THEN + IF(.NOT.PRESENT(PSPVOR)) THEN + CALL ABORT_TRANS('INV_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') + ENDIF + IUBOUND(1:4)=UBOUND(PGPUV) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_UV_G) THEN + WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G + CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') + ENDIF + IF(IUBOUND(3) < IF_UV_PAR) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') + ENDIF +ENDIF +IF(PRESENT(PGP2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('INV_TRANS:PSPSC2 HAS TO BE PRESENT WHEN PGP2 IS') + ENDIF +ENDIF +IF(IF_SC2_G > 0) THEN + IF(PRESENT(PGP2)) THEN + IUBOUND(1:3)=UBOUND(PGP2) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC2_G) THEN + WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G + CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('INV_TRANS:PGP2 MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('INV_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') + ENDIF +ENDIF +IF(IF_SC3A_G3 > 0) THEN + IF(PRESENT(PGP3A)) THEN + IUBOUND=UBOUND(PGP3A) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3A_G2) THEN + WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 + CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& + & IUBOUND(3),IF_SC3A_G3 + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('INV_TRANS:PGP3A MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('INV_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') + ENDIF +ENDIF +IF(IF_SC3B_G3 > 0) THEN + IF(PRESENT(PGP3B)) THEN + IUBOUND=UBOUND(PGP3B) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3B_G2) THEN + WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 + CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& + & IUBOUND(3),IF_SC3B_G3 + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('INV_TRANS:PGP3B MISSING') + ENDIF +ENDIF +CALL GSTATS(1807,1) + +! ------------------------------------------------------------------ + +! Perform transform +CALL EINV_TRANS_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_OUT_LT,& + & IF_UV,IF_SCALARS,IF_SCDERS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PMEANU,PMEANV ) +IF (LHOOK) CALL DR_HOOK('EINV_TRANS',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +!endif INTERFACE + +END SUBROUTINE EINV_TRANS + diff --git a/src/etrans/etrans/external/einv_transad.F90 b/src/etrans/etrans/external/einv_transad.F90 new file mode 100644 index 000000000..0f38dd37e --- /dev/null +++ b/src/etrans/etrans/external/einv_transad.F90 @@ -0,0 +1,609 @@ +SUBROUTINE EINV_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & FSPGL_PROC,& + & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) + +!**** *EINV_TRANSAD* - Inverse spectral transform - adjoint. + +! Purpose. +! -------- +! Interface routine for the inverse spectral transform - adjoint + +!** Interface. +! ---------- +! CALL EINV_TRANSAD(...) + +! Explicit arguments : All arguments except from PGP are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition +! LDSCDERS - indicating if derivatives of scalar variables are req. +! LDVORGP - indicating if grid-point vorticity is req. +! LDDIVGP - indicating if grid-point divergence is req. +! LDUVDER - indicating if E-W derivatives of u and v are req. +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (output) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! vorticity : IF_UV_G fields (if psvor present and LDVORGP) +! divergence : IF_UV_G fields (if psvor present and LDDIVGP) +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) +! N-S derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) +! E-W derivative of u : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of v : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) + +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split + +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling INV_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. + +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v,vor,div ...) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A if no derivatives, 3 times that with der.) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B if no derivatives, 3 times that with der.) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 if no derivatives, 3 times that with der.) + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ELTDIR_CTLAD - control of Legendre transform +! EFTDIR_CTLAD - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! G. Radnoti: like in direct code: IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR, NOUT, NPROMATR +!USE TPM_DIM +USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & + & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA +USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV +!USE TPM_GEOMETRY +!USE TPM_FIELDS +!USE TPM_FFT + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE EINV_TRANS_CTLAD_MOD ,ONLY : EINV_TRANS_CTLAD +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) +LOGICAL ,OPTIONAL,INTENT(IN) :: LDSCDERS +LOGICAL ,OPTIONAL,INTENT(IN) :: LDVORGP +LOGICAL ,OPTIONAL,INTENT(IN) :: LDDIVGP +LOGICAL ,OPTIONAL,INTENT(IN) :: LDUVDER +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANV(:) +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC +!ifndef INTERFACE + +! Local varaibles +INTEGER(KIND=JPIM) :: IUBOUND(4),J +INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP,IF_OUT_LT +INTEGER(KIND=JPIM) :: IF_SCDERS,IF_UV_PAR +INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G2,IF_SC3A_G3,IF_SC3B_G2,IF_SC3B_G3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EINV_TRANSAD',0,ZHOOK_HANDLE) +CALL GSTATS(1809,0) + +! Set current resolution +CALL ESET_RESOL(KRESOL) + +! Set defaults + +LVORGP = .FALSE. +LDIVGP = .FALSE. +LUVDER = .FALSE. +IF_UV = 0 +IF_UV_G = 0 +IF_UV_PAR = 0 +IF_SCALARS = 0 +IF_SCALARS_G = 0 +IF_SCDERS = 0 +NF_SC2 = 0 +NF_SC3A = 0 +NF_SC3B = 0 +IF_SC2_G = 0 +IF_SC3A_G2 = 0 +IF_SC3B_G2 = 0 +IF_SC3A_G3 = 0 +IF_SC3B_G3 = 0 +NPROMA = D%NGPTOT +LSCDERS = .FALSE. + +! Decide requirements + +IF(PRESENT(KVSETUV)) THEN + IF_UV_G = UBOUND(KVSETUV,1) + IF_UV_PAR = 2 + DO J=1,IF_UV_G + IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN + WRITE(NERR,*) 'EINV_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETUV(J) == MYSETV) THEN + IF_UV = IF_UV+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPVOR)) THEN + IF_UV = UBOUND(PSPVOR,1) + IF_UV_G = IF_UV + IF_UV_PAR = 2 +ENDIF + +IF(PRESENT(KVSETSC)) THEN + IF_SCALARS_G = UBOUND(KVSETSC,1) + DO J=1,IF_SCALARS_G + IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN + WRITE(NERR,*) 'EINV_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD:KVSETSC TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSCALAR)) THEN + IF_SCALARS = UBOUND(PSPSCALAR,1) + IF_SCALARS_G = IF_SCALARS +ENDIF + +IF(PRESENT(KVSETSC2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:KVSETSC2 BUT NOT PSPSC2') + ENDIF + IF_SC2_G = UBOUND(KVSETSC2,1) + IF_SCALARS_G = IF_SCALARS_G+UBOUND(KVSETSC2,1) + DO J=1,UBOUND(KVSETSC2,1) + IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN + WRITE(NERR,*) 'EINV_TRANSAD:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD:KVSETSC2 TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC2(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+1 + NF_SC2 = NF_SC2+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC2)) THEN + IF_SC2_G = UBOUND(PSPSC2,1) + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC2,1) + IF_SCALARS_G = IF_SCALARS_G +UBOUND(PSPSC2,1) + NF_SC2 = UBOUND(PSPSC2,1) +ENDIF + +IF(PRESENT(KVSETSC3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:KVSETSC3A BUT NOT PSPSC3A') + ENDIF + IF_SC3A_G2 = UBOUND(KVSETSC3A,1) + IF_SC3A_G3 = UBOUND(PSPSC3A,3) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G2*IF_SC3A_G3 + DO J=1,UBOUND(KVSETSC3A,1) + IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN + WRITE(NERR,*) 'EINV_TRANSAD:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV + CALL ABORT_TRANS& + & ('INV_TRANSAD:KVSETSC3A TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3A(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,3) + NF_SC3A = NF_SC3A+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3A)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,1)*UBOUND(PSPSC3A,3) + IF_SC3A_G2 = UBOUND(PSPSC3A,1) + IF_SC3A_G3 = UBOUND(PSPSC3A,3) + IF_SCALARS_G = IF_SCALARS_G + IF_SC3A_G2*IF_SC3A_G3 + NF_SC3A = UBOUND(PSPSC3A,1) +ENDIF + +IF(PRESENT(KVSETSC3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:KVSETSC3B BUT NOT PSPSC3B') + ENDIF + IF_SC3B_G2 = UBOUND(KVSETSC3B,1) + IF_SC3B_G3 = UBOUND(PSPSC3B,3) + IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G2*IF_SC3B_G3 + DO J=1,UBOUND(KVSETSC3B,1) + IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN + WRITE(NERR,*) 'EINV_TRANSAD:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD:KVSETSC3B TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSETSC3B(J) == MYSETV) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,3) + NF_SC3B = NF_SC3B+1 + ENDIF + ENDDO +ELSEIF(PRESENT(PSPSC3B)) THEN + IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,1)*UBOUND(PSPSC3B,3) + IF_SC3B_G2 = UBOUND(PSPSC3B,1) + IF_SC3B_G3 = UBOUND(PSPSC3B,3) + IF_SCALARS_G = IF_SCALARS_G + IF_SC3B_G2*IF_SC3B_G3 + NF_SC3B = UBOUND(PSPSC3B,1) +ENDIF + +IF (IF_SCALARS > 0) THEN + IF(PRESENT(LDSCDERS)) THEN + LSCDERS = LDSCDERS + IF (LSCDERS) IF_SCDERS = IF_SCALARS + ENDIF +ENDIF + +IF(PRESENT(KPROMA)) THEN + NPROMA = KPROMA +ENDIF + +IF(PRESENT(LDVORGP)) THEN + LVORGP = LDVORGP +ENDIF + +IF(PRESENT(LDDIVGP)) THEN + LDIVGP = LDDIVGP +ENDIF + +IF(PRESENT(LDUVDER)) THEN + LUVDER = LDUVDER +ENDIF + +! Compute derived variables + +IF(LVORGP) LDIVGP = .TRUE. + +NGPBLKS = (D%NGPTOT-1)/NPROMA+1 + +IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS + +IF(IF_UV > 0 .AND. LVORGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV +ENDIF +IF(IF_UV > 0 .AND. LDIVGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV +ENDIF +IF_FS = IF_OUT_LT+IF_SCDERS +IF(IF_UV > 0 .AND. LUVDER) THEN + IF_FS = IF_FS+2*IF_UV +ENDIF + +IF_GP = 2*IF_UV_G+IF_SCALARS_G +IF(LSCDERS) THEN + IF_GP = IF_GP+2*IF_SCALARS_G + IF_SC2_G = IF_SC2_G*3 + IF_SC3A_G3 = IF_SC3A_G3*3 + IF_SC3B_G3 = IF_SC3B_G3*3 +ENDIF +IF(IF_UV_G > 0 .AND. LVORGP) THEN + IF_GP = IF_GP+IF_UV_G + IF_UV_PAR = IF_UV_PAR+1 +ENDIF +IF(IF_UV_G > 0 .AND. LDIVGP) THEN + IF_GP = IF_GP+IF_UV_G + IF_UV_PAR = IF_UV_PAR+1 +ENDIF +IF(IF_UV_G > 0 .AND. LUVDER) THEN + IF_GP = IF_GP+2*IF_UV_G + IF_UV_PAR = IF_UV_PAR+2 +ENDIF + +! Consistency checks + +IF (IF_UV > 0) THEN + IF(.NOT. PRESENT(PSPVOR) ) THEN + CALL ABORT_TRANS("EINV_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING") + ENDIF + IF(UBOUND(PSPVOR,1) < IF_UV) THEN + WRITE(NERR,*)'EINV_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& + & UBOUND(PSPVOR,1),IF_UV + CALL ABORT_TRANS("EINV_TRANSAD : PSPVOR TOO SHORT") + ENDIF + IF(.NOT. PRESENT(PSPDIV) ) THEN + CALL ABORT_TRANS("EINV_TRANSAD : IF_UV > 0 BUT PSPDIV MISSING") + ENDIF + IF(UBOUND(PSPDIV,1) < IF_UV) THEN + WRITE(NERR,*)'INV_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& + & UBOUND(PSPDIV,1),IF_UV + CALL ABORT_TRANS("EINV_TRANSAD : PSPDIV TOO SHORT") + ENDIF +ENDIF + +IF (IF_SCALARS > 0) THEN + IF(PRESENT(PSPSCALAR)) THEN + IF(PRESENT(PSPSC3A))THEN + CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC3B))THEN + CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') + ENDIF + IF(PRESENT(PSPSC2))THEN + CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') + ENDIF + IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN + WRITE(NERR,*)'EINV_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& + & UBOUND(PSPSCALAR,1),IF_SCALARS + CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR TOO SHORT') + ENDIF + ELSEIF(PRESENT(PSPSC3A)) THEN + ENDIF +ENDIF + +IF(IF_UV_G == 0) THEN + LUVDER = .FALSE. +ENDIF + +IF(NPRTRV >1) THEN + IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN + WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& + & NPRTRV,IF_UV + CALL ABORT_TRANS('EINV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSCALAR) .AND. .NOT. PRESENT(KVSETSC)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSCALAR) AND NOT PRESENT(KVSETSC)',& + & NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC2) .AND. .NOT. PRESENT(KVSETSC2)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC2) AND NOT PRESENT(KVSETSC2)',& + & NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3A) .AND. .NOT. PRESENT(KVSETSC3A)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3A) AND NOT PRESENT(KVSETSC3A)',& + & NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF + IF(PRESENT(PSPSC3B) .AND. .NOT. PRESENT(KVSETSC3B)) THEN + WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3B) AND NOT PRESENT(KVSETSC3B)',& + & NPRTRV + CALL ABORT_TRANS('EINV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF +ENDIF + +IF(PRESENT(PGP)) THEN + IF(PRESENT(PGPUV)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGPUV CAN NOT BOTH BE PRESENT') + ENDIF + IF(PRESENT(PGP3A)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP3A CAN NOT BOTH BE PRESENT') + ENDIF + IF(PRESENT(PGP3B)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP3B CAN NOT BOTH BE PRESENT') + ENDIF + IF(PRESENT(PGP2)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP2 CAN NOT BOTH BE PRESENT') + ENDIF + IUBOUND(1:3)=UBOUND(PGP) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(2) < IF_GP) THEN + WRITE(NOUT,*)'EINV_TRANSAD:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP + WRITE(NOUT,*)'IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER ',& + & IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER + CALL ABORT_TRANS('EINV_TRANSAD:SECOND DIMENSION OF PGP TOO SMALL ') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP TOO SMALL ') + ENDIF +ELSE + IF(NPROMATR > 0 .AND. 2*IF_UV_G+IF_SCALARS_G > NPROMATR) THEN + CALL ABORT_TRANS('EINV_TRANSAD:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') + ENDIF +ENDIF + +IF(PRESENT(PGPUV)) THEN + IF(.NOT.PRESENT(PSPVOR)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') + ENDIF + IUBOUND(1:4)=UBOUND(PGPUV) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_UV_G) THEN + WRITE(NOUT,*)'EINV_TRANSAD:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G + CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGPUV INCONSISTENT ') + ENDIF + IF(IUBOUND(3) < IF_UV_PAR) THEN + WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR + CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') + ENDIF +ENDIF + +IF(PRESENT(PGP2)) THEN + IF(.NOT.PRESENT(PSPSC2)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PSPSC2 HAS TO BE PRESENT WHEN PGP2 IS') + ENDIF +ENDIF +IF(IF_SC2_G > 0) THEN + IF(PRESENT(PGP2)) THEN + IUBOUND(1:3)=UBOUND(PGP2) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP2 TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC2_G) THEN + WRITE(NOUT,*)'EINV_TRANSAD:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G + CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP2 INCONSISTENT') + ENDIF + IF(IUBOUND(3) < NGPBLKS) THEN + WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('EINV_TRANSAD:PGP2 MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3A)) THEN + IF(.NOT.PRESENT(PSPSC3A)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') + ENDIF +ENDIF +IF(IF_SC3A_G3 > 0) THEN + IF(PRESENT(PGP3A)) THEN + IUBOUND=UBOUND(PGP3A) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3A_G2) THEN + WRITE(NOUT,*)'EINV_TRANSAD:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 + CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN + WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP3A INCONSISTENT ',& + & IUBOUND(3),IF_SC3A_G3 + CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP3A INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'EINV_TRANSAD:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('EINV_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('EINV_TRANSAD:PGP3A MISSING') + ENDIF +ENDIF + +IF(PRESENT(PGP3B)) THEN + IF(.NOT.PRESENT(PSPSC3B)) THEN + CALL ABORT_TRANS('EINV_TRANSAD:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') + ENDIF +ENDIF +IF(IF_SC3B_G3 > 0) THEN + IF(PRESENT(PGP3B)) THEN + IUBOUND=UBOUND(PGP3B) + IF(IUBOUND(1) < NPROMA) THEN + WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL ') + ENDIF + IF(IUBOUND(2) /= IF_SC3B_G2) THEN + WRITE(NOUT,*)'EINV_TRANSAD:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 + CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN + WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP3B INCONSISTENT ',& + & IUBOUND(3),IF_SC3B_G3 + CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP3B INCONSISTENT ') + ENDIF + IF(IUBOUND(4) < NGPBLKS) THEN + WRITE(NOUT,*)'EINV_TRANSAD:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('EINV_TRANSAD:FOURTH DIMENSION OF PGP3B TOO SMALL ') + ENDIF + ELSE + CALL ABORT_TRANS('EINV_TRANSAD:PGP3B MISSING') + ENDIF +ENDIF +CALL GSTATS(1809,1) + +! ------------------------------------------------------------------ + +! Perform transform + +CALL EINV_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_OUT_LT,& + & IF_UV,IF_SCALARS,IF_SCDERS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PMEANU,PMEANV) +IF (LHOOK) CALL DR_HOOK('EINV_TRANSAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +!endif INTERFACE + +END SUBROUTINE EINV_TRANSAD + diff --git a/src/etrans/etrans/external/esetup_trans.F90 b/src/etrans/etrans/external/esetup_trans.F90 new file mode 100644 index 000000000..f01b0a77c --- /dev/null +++ b/src/etrans/etrans/external/esetup_trans.F90 @@ -0,0 +1,308 @@ +SUBROUTINE ESETUP_TRANS(KMSMAX,KSMAX,KDGL,KDGUX,KLOEN,LDSPLIT,& + & KTMAX,KRESOL,PEXWN,PEYWN,PWEIGHT,LDGRIDONLY,KNOEXTZL,KNOEXTZG, & + & LDUSEFFTW,LD_ALL_FFTW) +!**** *ESETUP_TRANS* - Setup transform package for specific resolution + +! Purpose. +! -------- +! To setup for making spectral transforms. Each call to this routine +! creates a new resolution up to a maximum of NMAX_RESOL set up in +! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can +! be called. + +!** Interface. +! ---------- +! CALL ESETUP_TRANS(...) + +! Explicit arguments : KLOEN,LDSPLIT are optional arguments +! -------------------- +! KSMAX - spectral truncation required +! KDGL - number of Gaussian latitudes +! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] +! LDSPLIT - true if split latitudes in grid-point space [false] +! KTMAX - truncation order for tendencies? +! KRESOL - the resolution identifier +! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution +! in spectral and grid-point space +! LDGRIDONLY - true if only grid space is required + + +! LDSPLIT describe the distribution among processors of +! grid-point data and has no relevance if you are using a single processor + +! LDUSEFFTW - Use FFTW for FFTs +! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ESETUP_DIMS - setup distribution independent dimensions +! SUEMP_TRANS_PRELEG - first part of setup of distr. environment +! SULEG - Compute Legandre polonomial and Gaussian +! Latitudes and Weights +! ESETUP_GEOM - Compute arrays related to grid-point geometry +! SUEMP_TRANS - Second part of setup of distributed environment +! SUEFFT - setup for FFT + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! 02-04-11 A. Bogatchev: Passing of TCDIS +! 02-11-14 C. Fischer: soften test on KDGL +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 +! A.Bogatchev 16-Sep-2010 Phasing cy37 +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 02-Mar-2012 Support for mixed multi-resolutions +! R. El Khatib 09-Aug-2012 %LAM in GEOM_TYPE +! R. El Khatib 14-Jun-2013 LENABLED +! R. El Khatib 01-Sep-2015 Support for FFTW +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR, NOUT, NPRINTLEV, MSETUP0, & + & NCUR_RESOL, NDEF_RESOL, NMAX_RESOL, LENABLED +USE TPM_DIM ,ONLY : R, DIM_RESOL +USE TPM_DISTR ,ONLY : D, DISTR_RESOL +USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL +USE TPM_FIELDS ,ONLY : FIELDS_RESOL +USE TPM_FFT ,ONLY : T, FFT_RESOL, TB, FFTB_RESOL +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, FFTW_RESOL +#endif +USE TPM_FLT ,ONLY : FLT_RESOL +USE TPM_CTL ,ONLY : CTL_RESOL + +USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL +USE TPMALD_DISTR ,ONLY : ALDDISTR_RESOL +USE TPMALD_FFT ,ONLY : TALD, ALDFFT_RESOL +USE TPMALD_FIELDS ,ONLY : ALDFIELDS_RESOL +USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE ESETUP_DIMS_MOD ,ONLY : ESETUP_DIMS +USE SUEMP_TRANS_MOD ,ONLY : SUEMP_TRANS +USE SUEMP_TRANS_PRELEG_MOD ,ONLY : SUEMP_TRANS_PRELEG +!USE SULEG_MOD +USE ESETUP_GEOM_MOD ,ONLY : ESETUP_GEOM +USE SUEFFT_MOD ,ONLY : SUEFFT +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Dummy arguments +INTEGER(KIND=JPIM),INTENT(IN) :: KMSMAX +INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(:) +LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT +LOGICAL ,OPTIONAL,INTENT(IN) :: LDGRIDONLY +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KTMAX +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KRESOL +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEXWN +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEYWN +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZG +LOGICAL ,OPTIONAL,INTENT(IN) :: LDUSEFFTW +LOGICAL ,OPTIONAL,INTENT(IN) :: LD_ALL_FFTW + +!ifndef INTERFACE + +! Local variables +LOGICAL :: LLP1,LLP2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ESETUP_TRANS',0,ZHOOK_HANDLE) + +IF(MSETUP0 == 0) THEN + CALL ABORT_TRANS('ESETUP_TRANS: SETUP_TRANS0 HAS TO BE CALLED BEFORE ESETUP_TRANS') +ENDIF +LLP1 = NPRINTLEV>0 +LLP2 = NPRINTLEV>1 +IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE ESETUP_TRANS ===' + +! Allocate resolution dependent structures common to global and LAM +IF(.NOT. ALLOCATED(DIM_RESOL)) THEN + NDEF_RESOL = 1 + ALLOCATE(DIM_RESOL(NMAX_RESOL)) + ALLOCATE(FIELDS_RESOL(NMAX_RESOL)) + ALLOCATE(GEOM_RESOL(NMAX_RESOL)) + ALLOCATE(DISTR_RESOL(NMAX_RESOL)) + ALLOCATE(FFT_RESOL(NMAX_RESOL)) + ALLOCATE(FFTB_RESOL(NMAX_RESOL)) +#ifdef WITH_FFTW + ALLOCATE(FFTW_RESOL(NMAX_RESOL)) +#endif + ALLOCATE(FLT_RESOL(NMAX_RESOL)) + ALLOCATE(CTL_RESOL(NMAX_RESOL)) + GEOM_RESOL(:)%LAM=.FALSE. + ALLOCATE(LENABLED(NMAX_RESOL)) + LENABLED(:)=.FALSE. +ELSE + NDEF_RESOL = NDEF_RESOL+1 + IF(NDEF_RESOL > NMAX_RESOL) THEN + CALL ABORT_TRANS('ESETUP_TRANS:NDEF_RESOL > NMAX_RESOL') + ENDIF +ENDIF +! Allocate LAM-specific resolution dependent structures +IF(.NOT. ALLOCATED(ALDDIM_RESOL)) THEN + ALLOCATE(ALDDIM_RESOL(NMAX_RESOL)) + ALLOCATE(ALDFIELDS_RESOL(NMAX_RESOL)) + ALLOCATE(ALDGEO_RESOL(NMAX_RESOL)) + ALLOCATE(ALDDISTR_RESOL(NMAX_RESOL)) + ALLOCATE(ALDFFT_RESOL(NMAX_RESOL)) +ENDIF + + +IF (PRESENT(KRESOL)) THEN + KRESOL=NDEF_RESOL +ENDIF + +! Point at structures due to be initialized +CALL ESET_RESOL(NDEF_RESOL) +IF(LLP1) WRITE(NOUT,*) '=== DEFINING RESOLUTION ',NCUR_RESOL + +! Defaults for optional arguments + +G%LREDUCED_GRID = .FALSE. +D%LGRIDONLY = .FALSE. +D%LSPLIT = .FALSE. +TALD%LFFT992=.TRUE. ! Use FFT992 interface for FFTs +#ifdef WITH_FFTW +TW%LFFTW=.FALSE. ! Use FFTW interface for FFTs +TW%LALL_FFTW=.FALSE. ! transform fields one at a time +#endif + +! NON-OPTIONAL ARGUMENTS +R%NSMAX = KSMAX +RALD%NMSMAX=KMSMAX +RALD%NDGUX=KDGUX +R%NDGL = KDGL +RALD%NDGLSUR=KDGL+2 +R%NDLON =KLOEN(1) + +! IMPLICIT argument : +G%LAM = .TRUE. + +IF (KDGL <= 0) THEN + CALL ABORT_TRANS ('ESETUP_TRANS: KDGL IS NOT A POSITIVE NUMBER') +ENDIF + +! Optional arguments + +ALLOCATE(G%NLOEN(R%NDGL)) +IF(LLP2)WRITE(NOUT,9) 'NLOEN ',SIZE(G%NLOEN ),SHAPE(G%NLOEN ) + +IF (G%LREDUCED_GRID) THEN + G%NLOEN(:) = KLOEN(1:R%NDGL) +ELSE + G%NLOEN(:) = R%NDLON +ENDIF + +IF(PRESENT(LDSPLIT)) THEN + D%LSPLIT = LDSPLIT +ENDIF + +IF(PRESENT(KTMAX)) THEN + R%NTMAX = KTMAX +ELSE + R%NTMAX = R%NSMAX +ENDIF +IF(R%NTMAX /= R%NSMAX) THEN + !This SHOULD work but I don't know how to test it /MH + WRITE(NERR,*) 'R%NTMAX /= R%NSMAX',R%NTMAX,R%NSMAX + CALL ABORT_TRANS('ESETUP_TRANS:R%NTMAX /= R%NSMAX HAS NOT BEEN VALIDATED') +ENDIF + +IF(PRESENT(PWEIGHT)) THEN + D%LWEIGHTED_DISTR = .TRUE. + IF( D%LWEIGHTED_DISTR .AND. .NOT.D%LSPLIT )THEN + CALL ABORT_TRANS('SETUP_TRANS: LWEIGHTED_DISTR=T AND LSPLIT=F NOT SUPPORTED') + ENDIF + IF(SIZE(PWEIGHT) /= SUM(G%NLOEN(:)) )THEN + CALL ABORT_TRANS('SETUP_TRANS:SIZE(PWEIGHT) /= SUM(G%NLOEN(:))') + ENDIF + ALLOCATE(D%RWEIGHT(SIZE(PWEIGHT))) + D%RWEIGHT(:)=PWEIGHT(:) +ELSE + D%LWEIGHTED_DISTR = .FALSE. +ENDIF + +IF(PRESENT(LDGRIDONLY)) THEN + D%LGRIDONLY=LDGRIDONLY +ENDIF + +IF (PRESENT(KNOEXTZL)) THEN + R%NNOEXTZL=KNOEXTZL +ELSE + R%NNOEXTZL=0 +ENDIF + +IF (PRESENT(KNOEXTZG)) THEN + R%NNOEXTZG=KNOEXTZG +ELSE + R%NNOEXTZG=0 +ENDIF + +#ifdef WITH_FFTW +IF(PRESENT(LDUSEFFTW)) THEN + TW%LFFTW=LDUSEFFTW +ENDIF +IF(PRESENT(LD_ALL_FFTW)) THEN + TW%LALL_FFTW=LD_ALL_FFTW +ENDIF +#endif + +IF(PRESENT(LDUSEFFTW)) THEN + TALD%LFFT992=.NOT.LDUSEFFTW +ELSE + TALD%LFFT992=.TRUE. +ENDIF + +! Setup resolution dependent structures +! ------------------------------------- + +! Setup distribution independent dimensions +CALL ESETUP_DIMS +IF (PRESENT(PEXWN)) GALD%EXWN=PEXWN +IF (PRESENT(PEYWN)) GALD%EYWN=PEYWN + +! First part of setup of distributed environment +CALL SUEMP_TRANS_PRELEG + +CALL GSTATS(1802,0) +! Compute arrays related to grid-point geometry +CALL ESETUP_GEOM +! Second part of setup of distributed environment +CALL SUEMP_TRANS +! Initialize Fast Fourier Transform package +CALL SUEFFT +CALL GSTATS(1802,1) + +! Signal the current resolution is active +LENABLED(NDEF_RESOL)=.TRUE. + +IF (LHOOK) CALL DR_HOOK('ESETUP_TRANS',1,ZHOOK_HANDLE) +! ------------------------------------------------------------------ +9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) + +!endif INTERFACE + +END SUBROUTINE ESETUP_TRANS + diff --git a/src/etrans/etrans/external/especnorm.F90 b/src/etrans/etrans/external/especnorm.F90 new file mode 100644 index 000000000..f816ee4c0 --- /dev/null +++ b/src/etrans/etrans/external/especnorm.F90 @@ -0,0 +1,136 @@ +SUBROUTINE ESPECNORM(PSPEC,KVSET,KMASTER,KRESOL,PMET,PNORM) + +!**** *ESPECNORM* - Compute global spectral norms + +! Purpose. +! -------- +! Interface routine for computing spectral norms + +!** Interface. +! ---------- +! CALL ESPECNORM(...) + +! Explicit arguments : All arguments optional +! -------------------- +! PSPEC(:,:) - Spectral array +! KVSET(:) - "B-Set" for each field +! KMASTER - processor to recieve norms +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PMET(:) - metric +! PNORM(:) - Norms (output for processor KMASTER) + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ESPNORM_CTL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NERR +!USE TPM_DIM +USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV, MYPROC + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE ESPNORM_CTL_MOD ,ONLY : ESPNORM_CTL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPEC(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSET(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KMASTER +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMET(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PNORM(:) +!ifndef INTERFACE + +INTEGER(KIND=JPIM) :: IMASTER,IFLD,IFLD_G,J +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Set current resolution +IF (LHOOK) CALL DR_HOOK('ESPECNORM',0,ZHOOK_HANDLE) +CALL ESET_RESOL(KRESOL) + +! Set defaults +IMASTER = 1 +IFLD = 0 + +IF(PRESENT(KMASTER)) THEN + IMASTER = KMASTER +ENDIF + +IF(PRESENT(KVSET)) THEN + IFLD_G = UBOUND(KVSET,1) + DO J=1,IFLD_G + IF(KVSET(J) > NPRTRV) THEN + WRITE(NERR,*) 'ESPECNORM:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV + CALL ABORT_TRANS('ESPECNORM:KVSET TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') + ENDIF + IF(KVSET(J) == MYSETV) THEN + IFLD = IFLD+1 + ENDIF + ENDDO +ELSE + IF(PRESENT(PSPEC)) THEN + IFLD = UBOUND(PSPEC,1) + ENDIF + IFLD_G = IFLD +ENDIF + +IF(NPRTRV >1) THEN + IF(IFLD > 0 .AND. .NOT. PRESENT(KVSET)) THEN + WRITE(NERR,*)'NPRTRV >1 AND IFLD > 0 AND NOT PRESENT(KVSET)',& + & NPRTRV,IFLD + CALL ABORT_TRANS('ESPECNORM: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') + ENDIF +ENDIF +IF(MYPROC == IMASTER) THEN + IF(.NOT. PRESENT(PNORM)) THEN + CALL ABORT_TRANS('ESPECNORM: PNORM NOT PRESENT') + ENDIF + IF(UBOUND(PNORM,1) < IFLD_G) THEN + CALL ABORT_TRANS('ESPECNORM: PNORM TOO SMALL') + ENDIF +ENDIF +IF(IFLD > 0 ) THEN + IF(.NOT. PRESENT(PSPEC)) THEN + CALL ABORT_TRANS('ESPECNORM: PSPEC NOT PRESENT') + ENDIF + IF(UBOUND(PSPEC,1) < IFLD) THEN + CALL ABORT_TRANS('ESPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') + ENDIF + IF(UBOUND(PSPEC,2) < D%NSPEC2) THEN + CALL ABORT_TRANS('ESPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') + ENDIF +ENDIF + +CALL ESPNORM_CTL(PSPEC,IFLD,IFLD_G,KVSET,IMASTER,PMET,PNORM) +IF (LHOOK) CALL DR_HOOK('ESPECNORM',1,ZHOOK_HANDLE) + +!endif INTERFACE + +! ------------------------------------------------------------------ + +END SUBROUTINE ESPECNORM diff --git a/src/etrans/etrans/external/etrans_end.F90 b/src/etrans/etrans/external/etrans_end.F90 new file mode 100644 index 000000000..18905e499 --- /dev/null +++ b/src/etrans/etrans/external/etrans_end.F90 @@ -0,0 +1,147 @@ +SUBROUTINE ETRANS_END(CDMODE) + +!**** *ETRANS_END* - Terminate transform package + +! Purpose. +! -------- +! Terminate transform package. Release all allocated arrays. + +!** Interface. +! ---------- +! CALL ETRANS_END + +! Explicit arguments : None +! -------------------- + +! Method. +! ------- + +! Externals. None +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 +! A.Bogatchev 16-Sep-2010 Phasing cy37 after G.Radnoti +! R. El Khatib 02-Mar-2012 Support for mixed multi-resolutions +! R. El Khatib 09-Jul-2013 LENABLED +! R. El Khatib 01-Set-2015 Support for FFTW +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : MSETUP0, NCUR_RESOL, NDEF_RESOL, NMAX_RESOL, LENABLED +USE TPM_DIM ,ONLY : R, DIM_RESOL +USE TPM_DISTR ,ONLY : D, DISTR_RESOL, NPRCIDS +USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL +USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL +USE TPM_FFT ,ONLY : T, FFT_RESOL, TB, FFTB_RESOL +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, FFTW_RESOL +#endif +USE TPM_FLT ,ONLY : S, FLT_RESOL +USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN +USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL +USE TPMALD_DISTR ,ONLY : DALD, ALDDISTR_RESOL +USE TPMALD_FFT ,ONLY : TALD, ALDFFT_RESOL +USE TPMALD_FIELDS ,ONLY : FALD, ALDFIELDS_RESOL +USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE EQ_REGIONS_MOD ,ONLY : N_REGIONS +USE EDEALLOC_RESOL_MOD ,ONLY : EDEALLOC_RESOL + +IMPLICIT NONE + +CHARACTER*5, OPTIONAL, INTENT(IN) :: CDMODE +! Local variables +CHARACTER*5 :: CLMODE +INTEGER(KIND=JPIM) :: JRES +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ETRANS_END',0,ZHOOK_HANDLE) +CLMODE='FINAL' +IF (PRESENT(CDMODE)) CLMODE=CDMODE +IF (CLMODE == 'FINAL') THEN + DO JRES=1,NDEF_RESOL + CALL EDEALLOC_RESOL(JRES) + ENDDO + NULLIFY(R) + IF (ALLOCATED(DIM_RESOL)) DEALLOCATE(DIM_RESOL) + NULLIFY(RALD) + IF (ALLOCATED(ALDDIM_RESOL)) DEALLOCATE(ALDDIM_RESOL) +!EQ_REGIONS + IF (ASSOCIATED(N_REGIONS)) THEN + DEALLOCATE(N_REGIONS) + NULLIFY (N_REGIONS) + ENDIF +!TPM_DISTR + NULLIFY(D) + IF (ALLOCATED(DISTR_RESOL)) DEALLOCATE(DISTR_RESOL) + NULLIFY(DALD) + IF (ALLOCATED(ALDDISTR_RESOL)) DEALLOCATE(ALDDISTR_RESOL) +!TPM_FFT + NULLIFY(T) + IF (ALLOCATED(FFT_RESOL)) DEALLOCATE(FFT_RESOL) + NULLIFY(TB) + IF( ALLOCATED(FFTB_RESOL) ) DEALLOCATE(FFTB_RESOL) +#ifdef WITH_FFTW + !TPM_FFTW + NULLIFY(TW) + DEALLOCATE(FFTW_RESOL) +#endif +!TPM_FLT + NULLIFY(S) + IF (ALLOCATED(FLT_RESOL)) DEALLOCATE(FLT_RESOL) + NULLIFY(TALD) + IF (ALLOCATED(ALDFFT_RESOL)) DEALLOCATE(ALDFFT_RESOL) + +!TPM_FIELDS + NULLIFY(F) + IF (ALLOCATED(FIELDS_RESOL)) DEALLOCATE(FIELDS_RESOL) + NULLIFY(FALD) + IF (ALLOCATED(ALDFIELDS_RESOL)) DEALLOCATE(ALDFIELDS_RESOL) + +!TPM_GEOMETRY + NULLIFY(G) + IF(ALLOCATED(GEOM_RESOL)) DEALLOCATE(GEOM_RESOL) + NULLIFY(GALD) + IF(ALLOCATED(ALDGEO_RESOL)) DEALLOCATE(ALDGEO_RESOL) +!TPM_TRANS + IF(ALLOCATED(FOUBUF_IN)) DEALLOCATE(FOUBUF_IN) + IF(ALLOCATED(FOUBUF)) DEALLOCATE(FOUBUF) + + IF (ALLOCATED(LENABLED)) DEALLOCATE(LENABLED) + MSETUP0 = 0 + NMAX_RESOL = 0 + NCUR_RESOL = 0 + NDEF_RESOL = 0 +ENDIF + +IF (CLMODE == 'FINAL' .OR. CLMODE == 'INTER') THEN + !EQ_REGIONS + IF (ASSOCIATED(N_REGIONS)) THEN + DEALLOCATE(N_REGIONS) + NULLIFY (N_REGIONS) + ENDIF + !TPM_DISTR + IF (ALLOCATED(NPRCIDS)) DEALLOCATE(NPRCIDS) +ENDIF +IF (LHOOK) CALL DR_HOOK('ETRANS_END',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +!endif INTERFACE + +END SUBROUTINE ETRANS_END + diff --git a/src/etrans/etrans/external/etrans_inq.F90 b/src/etrans/etrans/external/etrans_inq.F90 new file mode 100644 index 000000000..1d580d60f --- /dev/null +++ b/src/etrans/etrans/external/etrans_inq.F90 @@ -0,0 +1,539 @@ +SUBROUTINE ETRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& + & KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& + & KMYMS,KESM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& + & KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& + & KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& + & KULTPP,KPTRLS,& + & KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& + & LDSPLITLAT,LDLINEAR_GRID,& + & KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,KDEF_RESOL,LDLAM,& + & PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KCPL2M,KCPL4M ,KPROCM) + +!**** *ETRANS_INQ* - Extract information from the transform package + +! Purpose. +! -------- +! Interface routine for extracting information from the T.P. + +!** Interface. +! ---------- +! CALL ETRANS_INQ(...) +! Explicit arguments : All arguments are optional. +! -------------------- +! KRESOL - resolution tag for which info is required ,default is the +! first defined resolution (input) + +! MULTI-TRANSFORMS MANAGEMENT +! KDEF_RESOL - number or resolutions defined +! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global + +! SPECTRAL SPACE +! KSPEC - number of complex spectral coefficients on this PE +! KSPEC2 - 2*KSPEC +! KSPEC2G - global KSPEC2 +! KSPEC2MX - maximun KSPEC2 among all PEs +! KNUMP - Number of spectral waves handled by this PE +! KGPTOT - Total number of grid columns on this PE +! KGPTOTG - Total number of grid columns on the Globe +! KGPTOTMX - Maximum number of grid columns on any of the PEs +! KGPTOTL - Number of grid columns one each PE (dimension +! N_REGIONS_NS:N_REGIONS_EW) +! KMYMS - This PEs spectral zonal wavenumbers +! KESM0 - Address in a spectral array of (m, n=m) +! KUMPP - No. of wave numbers each wave set is responsible for +! KPOSSP - Defines partitioning of global spectral fields among PEs +! KPTRMS - Pointer to the first wave number of a given a-set +! KALLMS - Wave numbers for all wave-set concatenated together +! to give all wave numbers in wave-set order +! KDIM0G - Defines partitioning of global spectral fields among PEs +! KSMAX - spectral truncation - n direction +! KMSMAX - spectral truncation - m direction +! KNVALUE - n value for each KSPEC2 spectral coeffient +! KMVALUE - m value for each KSPEC2 spectral coeffient +! LDLINEAR_GRID : .TRUE. if the grid is linear + +! GRIDPOINT SPACE +! KFRSTLAT - First latitude of each a-set in grid-point space +! KLSTTLAT - Last latitude of each a-set in grid-point space +! KFRSTLOFF - Offset for first lat of own a-set in grid-point space +! KPTRLAT - Pointer to the start of each latitude +! KPTRFRSTLAT - Pointer to the first latitude of each a-set in +! NSTA and NONL arrays +! KPTRLSTLAT - Pointer to the last latitude of each a-set in +! NSTA and NONL arrays +! KPTRFLOFF - Offset for pointer to the first latitude of own a-set +! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 +! KSTA - Position of first grid column for the latitudes on a +! processor. The information is available for all processors. +! The b-sets are distinguished by the last dimension of +! nsta().The latitude band for each a-set is addressed by +! nptrfrstlat(jaset),nptrlstlat(jaset), and +! nptrfloff=nptrfrstlat(myseta) on this processors a-set. +! Each split latitude has two entries in nsta(,:) which +! necessitates the rather complex addressing of nsta(,:) +! and the overdimensioning of nsta by N_REGIONS_NS. +! KONL - Number of grid columns for the latitudes on a processor. +! Similar to nsta() in data structure. +! LDSPLITLAT - TRUE if latitude is split in grid point space over +! two a-sets + +! FOURIER SPACE +! KULTPP - number of latitudes for which each a-set is calculating +! the FFT's. +! KPTRLS - pointer to first global latitude of each a-set for which +! it performs the Fourier calculations + +! LEGENDRE +! PMU - sin(Gaussian latitudes) +! PGW - Gaussian weights +! PRPNM - Legendre polynomials +! KLEI3 - First dimension of Legendre polynomials +! KSPOLEGL - Second dimension of Legendre polynomials +! KPMS - Adress for legendre polynomial for given M (NSMAX) +! PLEPINM - Eigen-values of the inverse Laplace operator + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 +! A.Bogatchev 16-Sep-2010 Phasing with TFL 36R4 +! R. El Khatib 08-Aug-2012 KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,LDLAM,KDEF_RESOL,LDLINEAR_GRID +! T. Dalkilic 28-Aug-2012 KCPL4M +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!ifndef INTERFACE + +USE TPM_GEN ,ONLY : NDEF_RESOL +USE TPM_DIM ,ONLY : R +USE TPM_DISTR ,ONLY : D, NPRTRNS, NPRTRW, MYSETV, MYSETW +USE TPMALD_DIM ,ONLY : RALD +USE TPMALD_DISTR ,ONLY : DALD +USE TPM_GEOMETRY ,ONLY : G +USE TPM_FIELDS ,ONLY : F +USE TPMALD_FIELDS + +USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & + & N_REGIONS_EW, N_REGIONS_NS +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!endif INTERFACE + +IMPLICIT NONE + +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2 +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2G +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2MX +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KNUMP +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOT +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTG +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTMX +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTL(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KMYMS(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KESM0(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KUMPP(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPOSSP(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRMS(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KALLMS(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KDIM0G(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLOFF +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFRSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFLOFF +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSTA(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KONL(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KULTPP(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLS(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW +LOGICAL ,OPTIONAL,INTENT(INOUT) :: LDSPLITLAT(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMU(:) +REAL(KIND=JPRB) ,OPTIONAL :: PGW(:) ! Argument NOT used +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PRPNM(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLEI3 +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPOLEGL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPMS(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL2M(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL4M(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPROCM(0:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMSMAX +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMVALUE(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PLEPINM(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL +LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM +LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLINEAR_GRID +!ifndef INTERFACE + +INTEGER(KIND=JPIM) :: IU1,IU2 +INTEGER(KIND=JPIM) :: IC, JN, JMLOC, IM, JJ, JM +INTEGER(KIND=JPIM) :: ISMAX(0:R%NSMAX),ISNAX(0:RALD%NMSMAX),ICPLM(0:RALD%NMSMAX) + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +! Set current resolution +IF (LHOOK) CALL DR_HOOK('ETRANS_INQ',0,ZHOOK_HANDLE) +CALL ESET_RESOL(KRESOL) + +IF(PRESENT(KSPEC)) KSPEC = D%NSPEC +IF(PRESENT(KSPEC2)) KSPEC2 = D%NSPEC2 +IF(PRESENT(KSPEC2G)) KSPEC2G = R%NSPEC2_G +IF(PRESENT(KSPEC2MX)) KSPEC2MX = D%NSPEC2MX +IF(PRESENT(KNUMP)) KNUMP = D%NUMP +IF(PRESENT(KGPTOT)) KGPTOT = D%NGPTOT +IF(PRESENT(KGPTOTG)) KGPTOTG = D%NGPTOTG +IF(PRESENT(KGPTOTMX)) KGPTOTMX = D%NGPTOTMX +IF(PRESENT(KFRSTLOFF)) KFRSTLOFF = D%NFRSTLOFF +IF(PRESENT(KPTRFLOFF)) KPTRFLOFF = D%NPTRFLOFF +IF(PRESENT(KPRTRW)) KPRTRW = NPRTRW +IF(PRESENT(KMYSETW)) KMYSETW = MYSETW +IF(PRESENT(KMYSETV)) KMYSETV = MYSETV +IF(PRESENT(KMY_REGION_NS)) KMY_REGION_NS = MY_REGION_NS +IF(PRESENT(KMY_REGION_EW)) KMY_REGION_EW = MY_REGION_EW +IF(PRESENT(LDLAM)) LDLAM = G%LAM +IF(PRESENT(KDEF_RESOL)) KDEF_RESOL = NDEF_RESOL + +IF(PRESENT(KGPTOTL)) THEN + IF(UBOUND(KGPTOTL,1) < N_REGIONS_NS) THEN + CALL ABORT_TRANS('ETRANS_INQ: KGPTOTL DIM 1 TOO SMALL') + ELSEIF(UBOUND(KGPTOTL,2) < N_REGIONS_EW) THEN + CALL ABORT_TRANS('ETRANS_INQ: KGPTOTL DIM 2 TOO SMALL') + ELSE + KGPTOTL(1:N_REGIONS_NS,1:N_REGIONS_EW) = D%NGPTOTL(:,:) + ENDIF +ENDIF + +IF(PRESENT(KMYMS)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KMYMS REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KMYMS,1) < D%NUMP) THEN + CALL ABORT_TRANS('ETRANS_INQ: KMYMS TOO SMALL') + ELSE + KMYMS(1:D%NUMP) = D%MYMS(:) + ENDIF +ENDIF + +IF(PRESENT(KESM0)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KESM0 REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KESM0,1) < RALD%NMSMAX) THEN + CALL ABORT_TRANS('ETRANS_INQ: KESM0 TOO SMALL') + ELSE + KESM0(0:RALD%NMSMAX) = DALD%NESM0(:) + ENDIF +ENDIF + +IF(PRESENT(KCPL2M)) THEN + IF(UBOUND(KCPL2M,1) < RALD%NMSMAX) THEN + CALL ABORT_TRANS('ETRANS_INQ: KCPL2M TOO SMALL') + ELSE + KCPL2M(0:RALD%NMSMAX) = DALD%NCPL2M(:) + ENDIF +ENDIF +IF(PRESENT(KPROCM)) THEN + IF(UBOUND(KPROCM,1) < RALD%NMSMAX) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPROCM TOO SMALL') + ELSE + KPROCM(0:RALD%NMSMAX) = D%NPROCM(:) + ENDIF +ENDIF + +IF(PRESENT(KUMPP)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KUMPP REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KUMPP,1) < NPRTRW) THEN + CALL ABORT_TRANS('ETRANS_INQ: KUMPP TOO SMALL') + ELSE + KUMPP(1:NPRTRW) = D%NUMPP(:) + ENDIF +ENDIF + +IF(PRESENT(KPOSSP)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPOSSP REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KPOSSP,1) < NPRTRW+1) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPOSSP TOO SMALL') + ELSE + KPOSSP(1:NPRTRW+1) = D%NPOSSP(:) + ENDIF +ENDIF + +IF(PRESENT(KPTRMS)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPTRMS REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KPTRMS,1) < NPRTRW) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPTRMS TOO SMALL') + ELSE + KPTRMS(1:NPRTRW) = D%NPTRMS(:) + ENDIF +ENDIF + +IF(PRESENT(KALLMS)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KALLMS REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KALLMS,1) < RALD%NMSMAX+1) THEN + CALL ABORT_TRANS('ETRANS_INQ: KALLMS TOO SMALL') + ELSE + KALLMS(1:RALD%NMSMAX+1) = D%NALLMS(:) + ENDIF +ENDIF + +IF(PRESENT(KDIM0G)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KDIM0G REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KDIM0G,1) < RALD%NMSMAX) THEN + CALL ABORT_TRANS('ETRANS_INQ: KDIM0G TOO SMALL') + ELSE + KDIM0G(0:RALD%NMSMAX) = D%NDIM0G(0:RALD%NMSMAX) + ENDIF +ENDIF + +IF(PRESENT(KFRSTLAT)) THEN + IF(UBOUND(KFRSTLAT,1) < N_REGIONS_NS) THEN + CALL ABORT_TRANS('ETRANS_INQ: KFRSTLAT TOO SMALL') + ELSE + KFRSTLAT(1:N_REGIONS_NS) = D%NFRSTLAT(:) + ENDIF +ENDIF + +IF(PRESENT(KLSTLAT)) THEN + IF(UBOUND(KLSTLAT,1) < N_REGIONS_NS) THEN + CALL ABORT_TRANS('ETRANS_INQ: KLSTLAT TOO SMALL') + ELSE + KLSTLAT(1:N_REGIONS_NS) = D%NLSTLAT(:) + ENDIF +ENDIF + +IF(PRESENT(KPTRLAT)) THEN + IF(UBOUND(KPTRLAT,1) < R%NDGL) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPTRLAT TOO SMALL') + ELSE + KPTRLAT(1:R%NDGL) = D%NPTRLAT(:) + ENDIF +ENDIF + +IF(PRESENT(KPTRFRSTLAT)) THEN + IF(UBOUND(KPTRFRSTLAT,1) < N_REGIONS_NS) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPTRFRSTLAT TOO SMALL') + ELSE + KPTRFRSTLAT(1:N_REGIONS_NS) = D%NPTRFRSTLAT(:) + ENDIF +ENDIF + +IF(PRESENT(KPTRLSTLAT)) THEN + IF(UBOUND(KPTRLSTLAT,1) < N_REGIONS_NS) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPTRLSTLAT TOO SMALL') + ELSE + KPTRLSTLAT(1:N_REGIONS_NS) = D%NPTRLSTLAT(:) + ENDIF +ENDIF + +IF(PRESENT(KSTA)) THEN + IF(UBOUND(KSTA,1) < R%NDGL+N_REGIONS_NS-1) THEN + CALL ABORT_TRANS('ETRANS_INQ: KSTA DIM 1 TOO SMALL') + ELSEIF(UBOUND(KSTA,2) < N_REGIONS_EW) THEN + CALL ABORT_TRANS('ETRANS_INQ: KSTA DIM 2 TOO SMALL') + ELSE + KSTA(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NSTA(:,:) + ENDIF +ENDIF + +IF(PRESENT(KONL)) THEN + IF(UBOUND(KONL,1) < R%NDGL+N_REGIONS_NS-1) THEN + CALL ABORT_TRANS('ETRANS_INQ: KONL DIM 1 TOO SMALL') + ELSEIF(UBOUND(KONL,2) < N_REGIONS_EW) THEN + CALL ABORT_TRANS('ETRANS_INQ: KONL DIM 2 TOO SMALL') + ELSE + KONL(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NONL(:,:) + ENDIF +ENDIF + +IF(PRESENT(LDSPLITLAT)) THEN + IF(UBOUND(LDSPLITLAT,1) < R%NDGL) THEN + CALL ABORT_TRANS('ETRANS_INQ: LDSPLITLAT TOO SMALL') + ELSE + LDSPLITLAT(1:R%NDGL) = D%LSPLITLAT(:) + ENDIF +ENDIF + +IF(PRESENT(KULTPP)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KULTPP REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KULTPP,1) < NPRTRNS) THEN + CALL ABORT_TRANS('ETRANS_INQ: KULTPP TOO SMALL') + ELSE + KULTPP(1:NPRTRNS) = D%NULTPP(:) + ENDIF +ENDIF + +IF(PRESENT(KPTRLS)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPTRLS REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KPTRLS,1) < NPRTRNS) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPTRLS TOO SMALL') + ELSE + KPTRLS(1:NPRTRNS) = D%NPTRLS(:) + ENDIF +ENDIF + +IF(PRESENT(PMU)) THEN + IF(UBOUND(PMU,1) < R%NDGL) THEN + CALL ABORT_TRANS('ETRANS_INQ: PMU TOO SMALL') + ELSE + PMU(1:R%NDGL) = F%RMU + ENDIF +ENDIF + +IF(PRESENT(PRPNM)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: PRPNM REQUIRED BUT LGRIDONLY=T') + ENDIF + IU1 = UBOUND(PRPNM,1) + IU2 = UBOUND(PRPNM,2) + IF(IU1 < R%NDGNH) THEN + CALL ABORT_TRANS('ETRANS_INQ:FIRST DIM. OF PRNM TOO SMALL') + ELSE + IU1 = MIN(IU1,R%NLEI3) + IU2 = MIN(IU2,D%NSPOLEGL) + PRPNM(1:IU1,1:IU2) = F%RPNM(1:IU1,1:IU2) + ENDIF +ENDIF +IF(PRESENT(KLEI3)) THEN + KLEI3=R%NLEI3 +ENDIF +IF(PRESENT(KSPOLEGL)) THEN + KSPOLEGL=D%NSPOLEGL +ENDIF +IF(PRESENT(KPMS)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPMS REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KPMS,1) < R%NSMAX) THEN + CALL ABORT_TRANS('ETRANS_INQ: KPMS TOO SMALL') + ELSE + KPMS(0:R%NSMAX) = D%NPMS(0:R%NSMAX) + ENDIF +ENDIF + +IF(PRESENT(KSMAX)) KSMAX = R%NSMAX +IF(PRESENT(KMSMAX)) KMSMAX = RALD%NMSMAX +IF(PRESENT(PLEPINM)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: PLEPINM REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(PLEPINM,1) < R%NSPEC_G/2) THEN + CALL ABORT_TRANS('ETRANS_INQ: PLEPINM TOO SMALL') + ELSEIF (LBOUND(PLEPINM,1) /= -1) THEN + CALL ABORT_TRANS('ETRANS_INQ: LOWER BOUND OF PLEPINM SHOULD BE -1') + ELSE + PLEPINM(:) = FALD%RLEPINM(:) + ENDIF +ENDIF +IF(PRESENT(KNVALUE)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(SIZE(KNVALUE) < D%NSPEC2) THEN + CALL ABORT_TRANS('ETRANS_INQ: KNVALUE TOO SMALL') + ELSE + CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) + DO JM=0,RALD%NMSMAX + ICPLM(JM) = 1*(ISNAX(JM)+1) + ENDDO + IC=1 + DO JMLOC=1,D%NUMP + IM=D%MYMS(JMLOC) + DO JN=0,ICPLM(IM)-1 + DO JJ=0,3 + KNVALUE(IC+JJ)=JN + ENDDO + IC=IC+4 + ENDDO + ENDDO + ENDIF +ENDIF + +IF(PRESENT(KMVALUE)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(SIZE(KMVALUE) < D%NSPEC2) THEN + CALL ABORT_TRANS('ETRANS_INQ: KMVALUE TOO SMALL') + ELSE + CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) + DO JM=0,RALD%NMSMAX + ICPLM(JM) = 1*(ISNAX(JM)+1) + ENDDO + IC=1 + DO JMLOC=1,D%NUMP + IM=D%MYMS(JMLOC) + DO JN=0,ICPLM(IM)-1 + DO JJ=0,3 + KMVALUE(IC+JJ)=IM + ENDDO + IC=IC+4 + ENDDO + ENDDO + ENDIF +ENDIF + +IF(PRESENT(KCPL4M)) THEN + IF(D%LGRIDONLY) THEN + CALL ABORT_TRANS('ETRANS_INQ: KCPL4M REQUIRED BUT LGRIDONLY=T') + ENDIF + IF(UBOUND(KCPL4M,1) < RALD%NMSMAX) THEN + CALL ABORT_TRANS('ETRANS_INQ: KCPL4M TOO SMALL') + ELSE + CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) + DO JM=0,RALD%NMSMAX + KCPL4M(JM) = 4*(ISNAX(JM)+1) + ENDDO + ENDIF +ENDIF + + +IF(PRESENT(LDLINEAR_GRID)) THEN + LDLINEAR_GRID = R%NSMAX > (R%NDGL -1)/3 .OR. RALD%NMSMAX > (R%NDLON -1)/3 +ENDIF + + +IF (LHOOK) CALL DR_HOOK('ETRANS_INQ',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +!endif INTERFACE + +END SUBROUTINE ETRANS_INQ diff --git a/src/etrans/etrans/external/etrans_release.F90 b/src/etrans/etrans/external/etrans_release.F90 new file mode 100644 index 000000000..ea4f5a8a2 --- /dev/null +++ b/src/etrans/etrans/external/etrans_release.F90 @@ -0,0 +1,51 @@ +SUBROUTINE ETRANS_RELEASE(KRESOL) + +!**** *ETRANS_RELEASE* - release a spectral resolution + +! Purpose. +! -------- +! Release all arrays related to a given resolution tag + +!** Interface. +! ---------- +! CALL ETRANS_RELEASE + +! Explicit arguments : KRESOL : resolution tag +! -------------------- + +! Method. +! ------- + +! Externals. None +! ---------- + +! Author. +! ------- +! R. El Khatib *METEO-FRANCE* + +! Modifications. +! -------------- +! Original : 09-Jul-2013 + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM + +!ifndef INTERFACE + +USE EDEALLOC_RESOL_MOD ,ONLY : EDEALLOC_RESOL +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL + +!endif INTERFACE + +! ------------------------------------------------------------------ + +CALL EDEALLOC_RESOL(KRESOL) + +! ------------------------------------------------------------------ + +END SUBROUTINE ETRANS_RELEASE diff --git a/src/etrans/etrans/include/edir_trans.h b/src/etrans/etrans/include/edir_trans.h new file mode 100644 index 000000000..6f9721723 --- /dev/null +++ b/src/etrans/etrans/include/edir_trans.h @@ -0,0 +1,135 @@ +INTERFACE +SUBROUTINE EDIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& +& KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& +& PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV,AUX_PROC) + + +!**** *EDIR_TRANS* - Direct spectral transform (from grid-point to spectral). + +! Purpose. +! -------- +! Interface routine for the direct spectral transform + +!** Interface. +! ---------- +! CALL EDIR_TRANS(...) + +! Explicit arguments : All arguments except from PGP are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (output) +! PSPDIV(:,:) - spectral divergence (output) +! PSPSCALAR(:,:) - spectral scalarvalued fields (output) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (input) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): +! +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) +! +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split + +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling DIR_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. + +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A ) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 ) +! PMEANU(:),PMEANV(:) - mean wind +! AUX_PROC - optional external procedure for biperiodization of +! aux.fields + +! Method. +! ------- + +! Externals. SET_RESOL - set resolution +! ---------- LTDIR_CTL - control of Legendre transform +! FTDIR_CTL - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL + +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP2(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANU(:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANV(:) +EXTERNAL AUX_PROC +OPTIONAL AUX_PROC + + +END SUBROUTINE EDIR_TRANS + +END INTERFACE diff --git a/src/etrans/etrans/include/edir_transad.h b/src/etrans/etrans/include/edir_transad.h new file mode 100644 index 000000000..7dc6fa0d3 --- /dev/null +++ b/src/etrans/etrans/include/edir_transad.h @@ -0,0 +1,131 @@ +INTERFACE +SUBROUTINE EDIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& +& KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& +& PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) + + +!**** *EDIR_TRANSAD* - Direct spectral transform - adjoint. + +! Purpose. +! -------- +! Interface routine for the direct spectral transform - adjoint + +!** Interface. +! ---------- +! CALL EDIR_TRANSAD(...) + +! Explicit arguments : All arguments except from PGP are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (output) +! PSPDIV(:,:) - spectral divergence (output) +! PSPSCALAR(:,:) - spectral scalarvalued fields (output) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (input) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): +! +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) +! +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split +! +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling DIR_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. + +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A ) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 ) +! +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- EDIR_TRANS_CTLAD - control routine +! + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL + +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANU(:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANV(:) + + +END SUBROUTINE EDIR_TRANSAD + + +END INTERFACE diff --git a/src/etrans/etrans/include/edist_grid.h b/src/etrans/etrans/include/edist_grid.h new file mode 100644 index 000000000..92e93aeb7 --- /dev/null +++ b/src/etrans/etrans/include/edist_grid.h @@ -0,0 +1,57 @@ +INTERFACE +SUBROUTINE EDIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) + +!**** *EDIST_GRID* - Distribute global gridpoint array among processors + +! Purpose. +! -------- +! Interface routine for distributing gridpoint array + +!** Interface. +! ---------- +! CALL EDIST_GRID(...) + +! Explicit arguments : +! -------------------- +! PGPG(:,:) - Global spectral array +! KFDISTG - Global number of fields to be distributed +! KPROMA - required blocking factor for gridpoint input +! KFROM(:) - Processor resposible for distributing each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:) - Local spectral array +! +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- DIST_GRID_CTL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG +INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) + + +! ------------------------------------------------------------------ + +END SUBROUTINE EDIST_GRID +END INTERFACE diff --git a/src/etrans/etrans/include/edist_spec.h b/src/etrans/etrans/include/edist_spec.h new file mode 100644 index 000000000..43b9b4bcf --- /dev/null +++ b/src/etrans/etrans/include/edist_spec.h @@ -0,0 +1,59 @@ +INTERFACE +SUBROUTINE EDIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& + & LDIM1_IS_FLD,KSORT) + +!**** *EDIST_SPEC* - Distribute global spectral array among processors + +! Purpose. +! -------- +! Interface routine for distributing spectral array + +!** Interface. +! ---------- +! CALL EDIST__SPEC(...) + +! Explicit arguments : +! -------------------- +! PSPECG(:,:) - Global spectral array +! KFDISTG - Global number of fields to be distributed +! KFROM(:) - Processor resposible for distributing each field +! KVSET(:) - "B-Set" for each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PSPEC(:,:) - Local spectral array +! +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- EDIST_SPEC_CONTROL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPECG(:,:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG +INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) + + +! ------------------------------------------------------------------ + +END SUBROUTINE EDIST_SPEC +END INTERFACE diff --git a/src/etrans/etrans/include/egath_grid.h b/src/etrans/etrans/include/egath_grid.h new file mode 100644 index 000000000..a9742c300 --- /dev/null +++ b/src/etrans/etrans/include/egath_grid.h @@ -0,0 +1,56 @@ +INTERFACE +SUBROUTINE EGATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) + +!**** *EGATH_GRID* - Gather global gridpoint array from processors + +! Purpose. +! -------- +! Interface routine for gathering gripoint array + +!** Interface. +! ---------- +! CALL EGATH_GRID(...) + +! Explicit arguments : +! -------------------- +! PGPG(:,:) - Global gridpoint array +! KFGATHG - Global number of fields to be gathered +! KPROMA - blocking factor for gridpoint input +! KTO(:) - Processor responsible for gathering each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - Local spectral array +! +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- GATH_GRID_CTL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG +INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +REAL(KIND=JPRB) , INTENT(IN) :: PGP(:,:,:) + + +! ------------------------------------------------------------------ + +END SUBROUTINE EGATH_GRID +END INTERFACE diff --git a/src/etrans/etrans/include/egath_spec.h b/src/etrans/etrans/include/egath_spec.h new file mode 100644 index 000000000..5a2842d0b --- /dev/null +++ b/src/etrans/etrans/include/egath_spec.h @@ -0,0 +1,64 @@ +INTERFACE +SUBROUTINE EGATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,KMSMAX,LDZA0IP) + +!**** *EGATH_SPEC* - Gather global spectral array from processors + +! Purpose. +! -------- +! Interface routine for gathering spectral array + +!** Interface. +! ---------- +! CALL EGATH_SPEC(...) + +! Explicit arguments : +! -------------------- +! PSPECG(:,:) - Global spectral array +! KFGATHG - Global number of fields to be gathered +! KTO(:) - Processor responsible for gathering each field +! KVSET(:) - "B-Set" for each field +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PSPEC(:,:) - Local spectral array +! LDIM1_IS_FLD - If TRUE first dimension of PSCPEC and PSPECG is the field dimension [.T.] +! +! Method. +! ------- + +! Externals. SET_RESOL - set resolution +! ---------- EGATH_SPEC_CONTROL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB + + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG +INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) +LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMSMAX +LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP + + +! ------------------------------------------------------------------ + +END SUBROUTINE EGATH_SPEC + +END INTERFACE diff --git a/src/etrans/etrans/include/egpnorm_trans.h b/src/etrans/etrans/include/egpnorm_trans.h new file mode 100644 index 000000000..8c7fc4e53 --- /dev/null +++ b/src/etrans/etrans/include/egpnorm_trans.h @@ -0,0 +1,59 @@ +INTERFACE +SUBROUTINE EGPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) + + +!**** *EGPNORM_TRANS* - calculate grid-point norms + +! Purpose. +! -------- +! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather +! than an approach using a more expensive global gather collective communication + +!** Interface. +! ---------- +! CALL EGPNORM_TRANS(...) + +! Explicit arguments : +! -------------------- +! PGP(:,:,:) - gridpoint fields (input) +! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where +! NPROMA is the blocking factor, KFIELDS the total number +! of fields and NGPBLKS the number of NPROMA blocks. +! KFIELDS - number of fields (input) +! (these do not have to be just levels) +! KPROMA - required blocking factor (input) +! PAVE - average (output) +! PMIN - minimum (input/output) +! PMAX - maximum (input/output) +! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX +! KRESOL - resolution tag (optional) +! default assumes first defined resolution +! + +! Author. +! ------- +! A.Bogatchev after gpnorm_trans + +! Modifications. +! -------------- +! Original : 12th Jun 2009 + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB),INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB),INTENT(OUT) :: PAVE(:) +REAL(KIND=JPRB),INTENT(INOUT) :: PMIN(:) +REAL(KIND=JPRB),INTENT(INOUT) :: PMAX(:) +INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS +INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA +LOGICAL,INTENT(IN) :: LDAVE_ONLY +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL + +END SUBROUTINE EGPNORM_TRANS +END INTERFACE diff --git a/src/etrans/etrans/include/einv_trans.h b/src/etrans/etrans/include/einv_trans.h new file mode 100644 index 000000000..143d883b8 --- /dev/null +++ b/src/etrans/etrans/include/einv_trans.h @@ -0,0 +1,151 @@ +INTERFACE +SUBROUTINE EINV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & FSPGL_PROC,& + & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) + +!**** *EINV_TRANS* - Inverse spectral transform. + +! Purpose. +! -------- +! Interface routine for the inverse spectral transform + +!** Interface. +! ---------- +! CALL EINV_TRANS(...) + +! Explicit arguments : All arguments are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition +! LDSCDERS - indicating if derivatives of scalar variables are req. +! LDVORGP - indicating if grid-point vorticity is req. +! LDDIVGP - indicating if grid-point divergence is req. +! LDUVDER - indicating if E-W derivatives of u and v are req. +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (output) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): +! +! vorticity : IF_UV_G fields (if psvor present and LDVORGP) +! divergence : IF_UV_G fields (if psvor present and LDDIVGP) +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) +! N-S derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) +! E-W derivative of u : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of v : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) +! +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split + +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling INV_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. + +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v,vor,div ...) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A if no derivatives, 3 times that with der.) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B if no derivatives, 3 times that with der.) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 if no derivatives, 3 times that with der.) +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ELTINV_CTL - control of Legendre transform +! EFTINV_CTL - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields +! and derivatives (IF_SCALARS_G) + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) +LOGICAL ,OPTIONAL, INTENT(IN) :: LDSCDERS +LOGICAL ,OPTIONAL, INTENT(IN) :: LDVORGP +LOGICAL ,OPTIONAL, INTENT(IN) :: LDDIVGP +LOGICAL ,OPTIONAL, INTENT(IN) :: LDUVDER +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANU(:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANV(:) + + +END SUBROUTINE EINV_TRANS + +END INTERFACE diff --git a/src/etrans/etrans/include/einv_transad.h b/src/etrans/etrans/include/einv_transad.h new file mode 100644 index 000000000..923864915 --- /dev/null +++ b/src/etrans/etrans/include/einv_transad.h @@ -0,0 +1,150 @@ +INTERFACE +SUBROUTINE EINV_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & FSPGL_PROC,& + & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) + +!**** *EINV_TRANSAD* - Inverse spectral transform - adjoint. + +! Purpose. +! -------- +! Interface routine for the inverse spectral transform - adjoint + +!** Interface. +! ---------- +! CALL EINV_TRANSAD(...) + +! Explicit arguments : All arguments except from PGP are optional. +! -------------------- +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) +! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) +! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition +! LDSCDERS - indicating if derivatives of scalar variables are req. +! LDVORGP - indicating if grid-point vorticity is req. +! LDDIVGP - indicating if grid-point divergence is req. +! LDUVDER - indicating if E-W derivatives of u and v are req. +! KPROMA - required blocking factor for gridpoint output +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) +! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) +! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PGP(:,:,:) - gridpoint fields (output) +! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where +! NPROMA is the blocking factor, IF_GP the total number +! of output fields and NGPBLKS the number of NPROMA blocks. +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): +! +! vorticity : IF_UV_G fields (if psvor present and LDVORGP) +! divergence : IF_UV_G fields (if psvor present and LDDIVGP) +! u : IF_UV_G fields (if psvor present) +! v : IF_UV_G fields (if psvor present) +! scalar fields : IF_SCALARS_G fields (if pspscalar present) +! N-S derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) +! E-W derivative of u : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of v : IF_UV_G fields (if psvor present and and LDUVDER) +! E-W derivative of scalar fields : IF_SCALARS_G fields (if pspscalar +! present and LDSCDERS) +! +! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length +! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction +! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the +! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral +! 'b-set' split + +! As an alternative to using PGP you can also use a combination of the +! following arrays. The reason for introducing these alternative ways +! of calling INV_TRANS is to avoid uneccessary copies where your data +! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. +! The use of any of these precludes the use of PGP and vice versa. +! +! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order +! described for PGP. The second dimension of PGPUV should +! be the same as the "global" first dimension of +! PSPVOR,PSPDIV (in the IFS this is the number of levels) +! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (u,v,vor,div ...) +! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3A if no derivatives, 3 times that with der.) +! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B +! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC3B if no derivatives, 3 times that with der.) +! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 +! dimensioned(NPROMA,IFLDS,NGPBLKS) +! IFLDS is the number of 'variables' (the same as in +! PSPSC2 if no derivatives, 3 times that with der.) + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ELTDIR_CTLAD - control of Legendre transform +! EFTDIR_CTLAD - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) +LOGICAL ,OPTIONAL, INTENT(IN) :: LDSCDERS +LOGICAL ,OPTIONAL, INTENT(IN) :: LDVORGP +LOGICAL ,OPTIONAL, INTENT(IN) :: LDDIVGP +LOGICAL ,OPTIONAL, INTENT(IN) :: LDUVDER +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP2(:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANU(:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANV(:) + + +END SUBROUTINE EINV_TRANSAD + +END INTERFACE diff --git a/src/etrans/etrans/include/esetup_trans.h b/src/etrans/etrans/include/esetup_trans.h new file mode 100644 index 000000000..15c99f17c --- /dev/null +++ b/src/etrans/etrans/include/esetup_trans.h @@ -0,0 +1,88 @@ +INTERFACE +SUBROUTINE ESETUP_TRANS(KMSMAX,KSMAX,KDGL,KDGUX,KLOEN,LDSPLIT,& + & KTMAX,KRESOL,PEXWN,PEYWN,PWEIGHT,LDGRIDONLY,KNOEXTZL,KNOEXTZG,& + & LDUSEFFTW,LD_ALL_FFTW) +!**** *ESETUP_TRANS* - Setup transform package for specific resolution + +! Purpose. +! -------- +! To setup for making spectral transforms. Each call to this routine +! creates a new resolution up to a maximum of NMAX_RESOL set up in +! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can +! be called. + +!** Interface. +! ---------- +! CALL ESETUP_TRANS(...) + +! Explicit arguments : KLOEN,LDSPLIT are optional arguments +! -------------------- +! KSMAX - spectral truncation required +! KDGL - number of Gaussian latitudes +! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] +! LDSPLIT - true if split latitudes in grid-point space [false] +! KTMAX - truncation order for tendencies? +! KRESOL - the resolution identifier +! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution +! in spectral and grid-point space +! LDGRIDONLY - true if only grid space is required + + +! LDSPLIT describe the distribution among processors of +! grid-point data and has no relevance if you are using a single processor + +! LDUSEFFTW - Use FFTW for FFTs +! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ESETUP_DIMS - setup distribution independent dimensions +! SUEMP_TRANS_PRELEG - first part of setup of distr. environment +! SULEG - Compute Legandre polonomial and Gaussian +! Latitudes and Weights +! ESETUP_GEOM - Compute arrays related to grid-point geometry +! SUEMP_TRANS - Second part of setup of distributed environment +! SUEFFT - setup for FFT + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! 02-04-11 A. Bogatchev: Passing of TCDIS +! 02-11-14 C. Fischer: soften test on KDGL +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 +! A.Bogatchev 16-Sep-2010 Phasing cy37 +! D. Degrauwe (Feb 2012): Alternative extension zone (E') + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Dummy arguments +INTEGER(KIND=JPIM),INTENT(IN) :: KMSMAX +INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(:) +LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT +LOGICAL ,OPTIONAL,INTENT(IN) :: LDGRIDONLY +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KTMAX +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KRESOL +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEXWN +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEYWN +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZG +LOGICAL ,OPTIONAL,INTENT(IN) :: LDUSEFFTW +LOGICAL ,OPTIONAL,INTENT(IN) :: LD_ALL_FFTW + +END SUBROUTINE ESETUP_TRANS +END INTERFACE diff --git a/src/etrans/etrans/include/especnorm.h b/src/etrans/etrans/include/especnorm.h new file mode 100644 index 000000000..7edf5d78c --- /dev/null +++ b/src/etrans/etrans/include/especnorm.h @@ -0,0 +1,56 @@ +INTERFACE +SUBROUTINE ESPECNORM(PSPEC,KVSET,KMASTER,KRESOL,PMET,PNORM) + +!**** *ESPECNORM* - Compute global spectral norms + +! Purpose. +! -------- +! Interface routine for computing spectral norms + +!** Interface. +! ---------- +! CALL ESPECNORM(...) + +! Explicit arguments : All arguments optional +! -------------------- +! PSPEC(:,:) - Spectral array +! KVSET(:) - "B-Set" for each field +! KMASTER - processor to recieve norms +! KRESOL - resolution tag which is required ,default is the +! first defined resulution (input) +! PMET(:) - metric +! PNORM(:) - Norms (output for processor KMASTER) +! +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- ESPNORM_CTL - control routine + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 + +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +! Declaration of arguments + + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PNORM(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL + +! ------------------------------------------------------------------ + +END SUBROUTINE ESPECNORM +END INTERFACE diff --git a/src/etrans/etrans/include/etrans_end.h b/src/etrans/etrans/include/etrans_end.h new file mode 100644 index 000000000..fb1090fb2 --- /dev/null +++ b/src/etrans/etrans/include/etrans_end.h @@ -0,0 +1,41 @@ +INTERFACE +SUBROUTINE ETRANS_END(CDMODE) + +!**** *ETRANS_END* - Terminate transform package + +! Purpose. +! -------- +! Terminate transform package. Release all allocated arrays. + +!** Interface. +! ---------- +! CALL ETRANS_END + +! Explicit arguments : None +! -------------------- + +! Method. +! ------- + +! Externals. None +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 +! A.Bogatchev 16-Sep-2010 Phasing cy37 after G.Radnoti + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +CHARACTER*5, OPTIONAL, INTENT(IN) :: CDMODE + +END SUBROUTINE ETRANS_END +END INTERFACE diff --git a/src/etrans/etrans/include/etrans_inq.h b/src/etrans/etrans/include/etrans_inq.h new file mode 100644 index 000000000..04f2e56e7 --- /dev/null +++ b/src/etrans/etrans/include/etrans_inq.h @@ -0,0 +1,172 @@ +INTERFACE +SUBROUTINE ETRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& + & KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& + & KMYMS,KESM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& + & KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& + & KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& + & KULTPP,KPTRLS,& + & KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& + & LDSPLITLAT,LDLINEAR_GRID,& + & KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,KDEF_RESOL,LDLAM,& + & PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KCPL2M,KCPL4M,KPROCM) + +!**** *ETRANS_INQ* - Extract information from the transform package + +! Purpose. +! -------- +! Interface routine for extracting information from the T.P. + +!** Interface. +! ---------- +! CALL ETRANS_INQ(...) +! Explicit arguments : All arguments are optional. +! -------------------- +! KRESOL - resolution tag for which info is required ,default is the +! first defined resulution (input) + +! MULTI-TRANSFORMS MANAGEMENT +! KDEF_RESOL - number or resolutions defined +! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global + +! SPECTRAL SPACE +! KSPEC - number of complex spectral coefficients on this PE +! KSPEC2 - 2*KSPEC +! KSPEC2G - global KSPEC2 +! KSPEC2MX - maximun KSPEC2 among all PEs +! KNUMP - Number of spectral waves handled by this PE +! KGPTOT - Total number of grid columns on this PE +! KGPTOTG - Total number of grid columns on the Globe +! KGPTOTMX - Maximum number of grid columns on any of the PEs +! KGPTOTL - Number of grid columns one each PE (dimension N_REGIONS_NS:N_REGIONS_EW) +! KMYMS - This PEs spectral zonal wavenumbers +! KESM0 - Address in a spectral array of (m, n=m) +! KUMPP - No. of wave numbers each wave set is responsible for +! KPOSSP - Defines partitioning of global spectral fields among PEs +! KPTRMS - Pointer to the first wave number of a given a-set +! KALLMS - Wave numbers for all wave-set concatenated together +! to give all wave numbers in wave-set order +! KDIM0G - Defines partitioning of global spectral fields among PEs +! KSMAX - spectral truncation - n direction +! KMSMAX - spectral truncation - m direction +! KNVALUE - n value for each KSPEC2 spectral coeffient +! KMVALUE - m value for each KSPEC2 spectral coeffient +! LDLINEAR_GRID : .TRUE. if the grid is linear + +! GRIDPOINT SPACE +! KFRSTLAT - First latitude of each a-set in grid-point space +! KLSTTLAT - Last latitude of each a-set in grid-point space +! KFRSTLOFF - Offset for first lat of own a-set in grid-point space +! KPTRLAT - Pointer to the start of each latitude +! KPTRFRSTLAT - Pointer to the first latitude of each a-set in +! NSTA and NONL arrays +! KPTRLSTLAT - Pointer to the last latitude of each a-set in +! NSTA and NONL arrays +! KPTRFLOFF - Offset for pointer to the first latitude of own a-set +! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 +! KSTA - Position of first grid column for the latitudes on a +! processor. The information is available for all processors. +! The b-sets are distinguished by the last dimension of +! nsta().The latitude band for each a-set is addressed by +! nptrfrstlat(jaset),nptrlstlat(jaset), and +! nptrfloff=nptrfrstlat(myseta) on this processors a-set. +! Each split latitude has two entries in nsta(,:) which +! necessitates the rather complex addressing of nsta(,:) +! and the overdimensioning of nsta by N_REGIONS_NS. +! KONL - Number of grid columns for the latitudes on a processor. +! Similar to nsta() in data structure. +! LDSPLITLAT - TRUE if latitude is split in grid point space over +! two a-sets + +! FOURIER SPACE +! KULTPP - number of latitudes for which each a-set is calculating +! the FFT's. +! KPTRLS - pointer to first global latitude of each a-set for which +! it performs the Fourier calculations + +! LEGENDRE +! PMU - sin(Gaussian latitudes) +! PGW - Gaussian weights +! PRPNM - Legendre polynomials +! KLEI3 - First dimension of Legendre polynomials +! KSPOLEGL - Second dimension of Legendre polynomials +! KPMS - Adress for legendre polynomial for given M (NSMAX) +! PLEPINM - Eigen-values of the inverse Laplace operator + +! Method. +! ------- + +! Externals. ESET_RESOL - set resolution +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 +! A.Bogatchev 16-Sep-2010 Phasing with TFL 36R4 +! R. El Khatib 08-Aug-2012 KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,LDLAM,KDEF_RESOL,LDLINEAR_GRID + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2 +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2G +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2MX +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KNUMP +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOT +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTG +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTMX +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTL(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KMYMS(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KESM0(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KUMPP(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPOSSP(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRMS(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KALLMS(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KDIM0G(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLOFF +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFRSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLSTLAT(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFLOFF +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSTA(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KONL(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KULTPP(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLS(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW +LOGICAL ,OPTIONAL,INTENT(INOUT) :: LDSPLITLAT(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMU(:) +REAL(KIND=JPRB) ,OPTIONAL :: PGW(:) ! Argument NOT used +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PRPNM(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLEI3 +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPOLEGL +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPMS(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL2M(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL4M(0:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPROCM(0:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMSMAX +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMVALUE(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PLEPINM(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL +LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM +LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLINEAR_GRID + +END SUBROUTINE ETRANS_INQ +END INTERFACE diff --git a/src/etrans/etrans/include/etrans_release.h b/src/etrans/etrans/include/etrans_release.h new file mode 100644 index 000000000..846424c87 --- /dev/null +++ b/src/etrans/etrans/include/etrans_release.h @@ -0,0 +1,6 @@ +INTERFACE +SUBROUTINE ETRANS_RELEASE(KRESOL) +USE PARKIND1 ,ONLY : JPIM +INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL +END SUBROUTINE ETRANS_RELEASE +END INTERFACE diff --git a/src/etrans/etrans/internal/cpl_int_mod.F90 b/src/etrans/etrans/internal/cpl_int_mod.F90 new file mode 100644 index 000000000..2b55a5b22 --- /dev/null +++ b/src/etrans/etrans/internal/cpl_int_mod.F90 @@ -0,0 +1,33 @@ +MODULE CPL_INT_MOD +CONTAINS +SUBROUTINE CPL_INT(PGTF,KENDROWL,KFIELDS,KFFIELDS,KLEN,KSTA,CPL_PROC,KPTRGP) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +IMPLICIT NONE +INTEGER(KIND=JPIM), INTENT(IN) :: KENDROWL +INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS +INTEGER(KIND=JPIM), INTENT(IN) :: KFFIELDS +INTEGER(KIND=JPIM), INTENT(IN) :: KLEN +INTEGER(KIND=JPIM), INTENT(IN) :: KSTA(KENDROWL) +INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB), INTENT(INOUT) :: PGTF(KFIELDS,KLEN) +EXTERNAL CPL_PROC + +INTEGER(KIND=JPIM) :: IPTRGP(KFIELDS) +INTEGER(KIND=JPIM) :: J +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +!-------------------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('CPL_INT_MOD:CPL_INT',0,ZHOOK_HANDLE) +IF(PRESENT(KPTRGP)) THEN + IPTRGP(:)=KPTRGP(1:KFIELDS) +ELSE + DO J=1,KFIELDS + IPTRGP(J)=J + ENDDO +ENDIF +CALL CPL_PROC(PGTF,KENDROWL,KFIELDS,KFFIELDS,KLEN,KSTA,IPTRGP) +IF (LHOOK) CALL DR_HOOK('CPL_INT_MOD:CPL_INT',1,ZHOOK_HANDLE) +END SUBROUTINE CPL_INT +END MODULE CPL_INT_MOD diff --git a/src/etrans/etrans/internal/easre1ad_mod.F90 b/src/etrans/etrans/internal/easre1ad_mod.F90 new file mode 100644 index 000000000..b382d7836 --- /dev/null +++ b/src/etrans/etrans/internal/easre1ad_mod.F90 @@ -0,0 +1,80 @@ +MODULE EASRE1AD_MOD +CONTAINS +SUBROUTINE EASRE1AD(KM,KMLOC,KF_OUT_LT,PIA) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_TRANS +USE EASRE1BAD_MOD ,ONLY : EASRE1BAD + +!**** *EASRE1AD* - Recombine antisymmetric and symmetric parts - adjoint + +! Purpose. +! -------- +! To recombine the antisymmetric and symmetric parts of the +! Fourier arrays and update the correct parts of the state +! variables. + +!** Interface. +! ---------- +! *CALL* *EASRE1AD(...) + +! Explicit arguments : +! -------------------- +! KM - zonal wavenumber +! KMLOC - local zonal wavenumber +! PAOA1 - antisymmetric part of Fourier +! fields for zonal wavenumber KM (basic +! variables and N-S derivatives) +! PSOA1 - symmetric part of Fourier +! fields for zonal wavenumber KM (basic +! variables and N-S derivatives) + +! Implicit arguments : None +! -------------------- + +! Method. +! ------- + +! Externals. EASRE1BAD - basic recombination routine +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From ASRE1AD in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM) , INTENT(IN) :: KM +INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC +INTEGER(KIND=JPIM) , INTENT(IN) :: KF_OUT_LT + +REAL(KIND=JPRB) , INTENT(OUT) :: PIA(:,:) + +INTEGER(KIND=JPIM) :: IFLDS +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EASRE1AD_MOD:EASRE1AD',0,ZHOOK_HANDLE) +IFLDS = KF_OUT_LT + +CALL EASRE1BAD(IFLDS,KM,KMLOC,PIA) +IF (LHOOK) CALL DR_HOOK('EASRE1AD_MOD:EASRE1AD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EASRE1AD +END MODULE EASRE1AD_MOD diff --git a/src/etrans/etrans/internal/easre1b_mod.F90 b/src/etrans/etrans/internal/easre1b_mod.F90 new file mode 100644 index 000000000..cae14b396 --- /dev/null +++ b/src/etrans/etrans/internal/easre1b_mod.F90 @@ -0,0 +1,93 @@ +MODULE EASRE1B_MOD +CONTAINS +SUBROUTINE EASRE1B(KFC,KM,KMLOC,PIA) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPMALD_DIM ,ONLY : RALD +USE TPM_TRANS ,ONLY : FOUBUF_IN +USE TPM_DISTR ,ONLY : D + +!**** *ASRE1B* - Recombine antisymmetric and symmetric parts + +! Purpose. +! -------- +! To recombine the antisymmetric and symmetric parts of the +! Fourier arrays and update the correct parts of the state +! variables. + +!** Interface. +! ---------- +! *CALL* *ASRE1B(..) + +! Explicit arguments : +! ------------------- KFC - number of fields (input-c) +! KM - zonal wavenumber(input-c) +! KMLOC - local version of KM (input-c) +! PAOA - antisymmetric part of Fourier +! fields for zonal wavenumber KM (input) +! PSOA - symmetric part of Fourier +! fields for zonal wavenumber KM (input) + +! Implicit arguments : FOUBUF_IN - output buffer (output) +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From ASRE1B in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! R. El Khatib 26-Aug-2021 Optimizations +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KFC +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC +REAL(KIND=JPRB), INTENT(IN) :: PIA(RALD%NDGLSUR+R%NNOEXTZG,KFC) + +INTEGER(KIND=JPIM) :: JFLD, JGL ,IPROC +INTEGER(KIND=JPIM) :: IISTAN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +!* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. +! --------------------------------------------------- +IF (LHOOK) CALL DR_HOOK('EASRE1B_MOD:EASRE1B',0,ZHOOK_HANDLE) +#ifdef __INTEL_COMPILER +!$OMP SIMD PRIVATE(JGL) +DO JFLD=1,KFC + DO JGL=1,R%NDGL + FOUBUF_IN((D%NSTAGT0B(D%NPROCL(JGL))+D%NPNTGTB1(KMLOC,JGL))*KFC+JFLD)=PIA(JGL,JFLD) + ENDDO +ENDDO +#else +DO JGL=1,R%NDGL + IPROC=D%NPROCL(JGL) + IISTAN=(D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*KFC + DO JFLD =1,KFC + FOUBUF_IN(IISTAN+JFLD)=PIA(JGL,JFLD) + ENDDO +ENDDO +#endif +IF (LHOOK) CALL DR_HOOK('EASRE1B_MOD:EASRE1B',1,ZHOOK_HANDLE) +! ------------------------------------------------------------------ + +END SUBROUTINE EASRE1B +END MODULE EASRE1B_MOD diff --git a/src/etrans/etrans/internal/easre1bad_mod.F90 b/src/etrans/etrans/internal/easre1bad_mod.F90 new file mode 100644 index 000000000..0aa6f3435 --- /dev/null +++ b/src/etrans/etrans/internal/easre1bad_mod.F90 @@ -0,0 +1,97 @@ +MODULE EASRE1BAD_MOD +CONTAINS +SUBROUTINE EASRE1BAD(KFC,KM,KMLOC,PIA) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPMALD_DIM ,ONLY : RALD +USE TPM_TRANS ,ONLY : FOUBUF_IN +USE TPM_DISTR ,ONLY : D + +!**** *EASRE1BAD* - Recombine antisymmetric and symmetric parts - adjoint + +! Purpose. +! -------- +! To recombine the antisymmetric and symmetric parts of the +! Fourier arrays and update the correct parts of the state +! variables. + +!** Interface. +! ---------- +! *CALL* *EASRE1BAD(..) + +! Explicit arguments : +! ------------------- KFC - number of fields (input-c) +! KM - zonal wavenumber(input-c) +! KMLOC - local version of KM (input-c) +! PAOA - antisymmetric part of Fourier +! fields for zonal wavenumber KM (input) +! PSOA - symmetric part of Fourier +! fields for zonal wavenumber KM (input) + +! Implicit arguments : FOUBUF_IN - output buffer (output) +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From ASRE1BAD in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! R. El Khatib 26-Aug-2021 Optimizations +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KFC +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC + +REAL(KIND=JPRB), INTENT(OUT) :: PIA(RALD%NDGLSUR+R%NNOEXTZG,KFC) + +INTEGER(KIND=JPIM) :: JFLD, JGL ,IPROC +INTEGER(KIND=JPIM) :: IISTAN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. +! --------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('EASRE1BAD_MOD:EASRE1BAD',0,ZHOOK_HANDLE) +#ifdef __INTEL_COMPILER +!$OMP SIMD PRIVATE(JGL) +DO JFLD =1,KFC + DO JGL=1,R%NDGL + PIA(JGL,JFLD)=FOUBUF_IN((D%NSTAGT0B(D%NPROCL(JGL))+D%NPNTGTB1(KMLOC,JGL))*KFC+JFLD) + ENDDO +ENDDO +#else +DO JGL=1,R%NDGL + IPROC=D%NPROCL(JGL) + DO JFLD =1,KFC + IISTAN=(D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*KFC + PIA(JGL,JFLD)=FOUBUF_IN(IISTAN+JFLD) + ENDDO +ENDDO +#endif +IF (LHOOK) CALL DR_HOOK('EASRE1BAD_MOD:EASRE1BAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EASRE1BAD +END MODULE EASRE1BAD_MOD diff --git a/src/etrans/etrans/internal/edealloc_resol_mod.F90 b/src/etrans/etrans/internal/edealloc_resol_mod.F90 new file mode 100644 index 000000000..5d341b92f --- /dev/null +++ b/src/etrans/etrans/internal/edealloc_resol_mod.F90 @@ -0,0 +1,102 @@ +MODULE EDEALLOC_RESOL_MOD +CONTAINS +SUBROUTINE EDEALLOC_RESOL(KRESOL) + +!**** *EDEALLOC_RESOL_MOD* - Deallocations of a resolution + +! Purpose. +! -------- +! Release allocated arrays for a given resolution + +!** Interface. +! ---------- +! CALL EDEALLOC_RESOL_MOD + +! Explicit arguments : KRESOL : resolution tag +! -------------------- + +! Method. +! ------- + +! Externals. None +! ---------- + +! Author. +! ------- +! R. El Khatib *METEO-FRANCE* + +! Modifications. +! -------------- +! Original : 09-Jul-2013 from etrans_end +! B. Bochenek (Apr 2015): Phasing: update +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +USE TPM_GEN ,ONLY : LENABLED, NOUT +USE TPM_DISTR ,ONLY : D +USE TPM_GEOMETRY ,ONLY : G +USE TPM_FIELDS ,ONLY : F +USE TPM_FFT ,ONLY : T +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW,DESTROY_PLANS_FFTW +#endif +USE TPM_FLT ,ONLY : S + +USE ESET_RESOL_MOD ,ONLY : ESET_RESOL + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KRESOL + +! ------------------------------------------------------------------ + +IF (.NOT.LENABLED(KRESOL)) THEN + + WRITE(UNIT=NOUT,FMT='('' EDEALLOC_RESOL WARNING: KRESOL = '',I3,'' ALREADY DISABLED '')') KRESOL + +ELSE + + CALL ESET_RESOL(KRESOL) + + !TPM_DISTR + DEALLOCATE(D%NFRSTLAT,D%NLSTLAT,D%NPTRLAT,D%NPTRFRSTLAT,D%NPTRLSTLAT) + DEALLOCATE(D%LSPLITLAT,D%NSTA,D%NONL,D%NGPTOTL,D%NPROCA_GP) + + IF(D%LWEIGHTED_DISTR) THEN + DEALLOCATE(D%RWEIGHT) + ENDIF + + IF(.NOT.D%LGRIDONLY) THEN + + DEALLOCATE(D%MYMS,D%NUMPP,D%NPOSSP,D%NPROCM,D%NDIM0G,D%NASM0,D%NATM0) + DEALLOCATE(D%NLATLS,D%NLATLE,D%NPMT,D%NPMS,D%NPMG,D%NULTPP,D%NPROCL) + DEALLOCATE(D%NPTRLS,D%NALLMS,D%NPTRMS,D%NSTAGT0B,D%NSTAGT1B,D%NPNTGTB0) + DEALLOCATE(D%NPNTGTB1,D%NLTSFTB,D%NLTSGTB,D%MSTABF) + DEALLOCATE(D%NSTAGTF) + + !TPM_FFT + DEALLOCATE(T%TRIGS,T%NFAX) +#ifdef WITH_FFTW + !TPM_FFTW + IF( TW%LFFTW )THEN + CALL DESTROY_PLANS_FFTW + ENDIF +#endif + !TPM_GEOMETRY + DEALLOCATE(G%NMEN,G%NDGLU) + + ELSE + + DEALLOCATE(G%NLOEN) + + ENDIF + + LENABLED(KRESOL)=.FALSE. + +ENDIF + +! ------------------------------------------------------------------ + +END SUBROUTINE EDEALLOC_RESOL +END MODULE EDEALLOC_RESOL_MOD diff --git a/src/etrans/etrans/internal/edir_trans_ctl_mod.F90 b/src/etrans/etrans/internal/edir_trans_ctl_mod.F90 new file mode 100644 index 000000000..34c6db0c5 --- /dev/null +++ b/src/etrans/etrans/internal/edir_trans_ctl_mod.F90 @@ -0,0 +1,202 @@ +MODULE EDIR_TRANS_CTL_MOD +CONTAINS +SUBROUTINE EDIR_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PMEANU,PMEANV,AUX_PROC) + +!**** *EDIR_TRANS_CTL* - Control routine for direct spectral transform. + +! Purpose. +! -------- +! Control routine for the direct spectral transform + +!** Interface. +! ---------- +! CALL EDIR_TRANS_CTL(...) + +! Explicit arguments : +! -------------------- +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity +! PSPDIV(:,:) - spectral divergence +! PSPSCALAR(:,:) - spectral scalarvalued fields +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! PMEANU,PMEANV - mean winds +! AUX_PROC - optional external procedure for biperiodization of +! aux.fields +! PGP(:,:,:) - gridpoint fields + +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! u : KF_UV_G fields +! v : KF_UV_G fields +! scalar fields : KF_SCALARS_G fields + +! Method. +! ------- + +! Externals. SHUFFLE - reshuffle fields for load balancing +! ---------- FIELD_SPLIT - split fields in NPROMATR packets +! LTDIR_CTL - control of Legendre transform +! FTDIR_CTL - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 01-01-03 +! G. Radnoti 01-03-13 adaptation to aladin +! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 +! 02-09-30 : P. Smolikova AUX_PROC for d4 in NH +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NPROMATR +!USE TPM_TRANS +!USE TPM_DISTR + +USE SHUFFLE_MOD ,ONLY : SHUFFLE +USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT +USE ELTDIR_CTL_MOD ,ONLY : ELTDIR_CTL +USE EFTDIR_CTL_MOD ,ONLY : EFTDIR_CTL + +IMPLICIT NONE + +! Declaration of arguments + +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP +INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANV(:) +EXTERNAL AUX_PROC +OPTIONAL AUX_PROC + +! Local variables + +INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) +INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) +INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) +INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G +INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP +INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Perform transform + +IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTL_MOD:EDIR_TRANS_CTL',0,ZHOOK_HANDLE) +IF_GPB = 2*KF_UV_G+KF_SCALARS_G +IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN + + ! Fields to be split into packets + + CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & + & KVSETUV,KVSETSC) + + IBLKS=(IF_GPB-1)/NPROMATR+1 + + DO JBLK=1,IBLKS + + CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& + & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& + & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) + + IF_FS = 2*IF_UV + IF_SCALARS + IF_GP = 2*IF_UV_G+IF_SCALARS_G + DO JFLD=1,IF_UV_G + IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) + IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) + ENDDO + DO JFLD=1,IF_SCALARS_G + IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) + ENDDO + DO JFLD=1,IF_UV + IPTRSPUV(JFLD) = ISTUV+JFLD-1 + ENDDO + DO JFLD=1,IF_SCALARS + IPTRSPSC(JFLD) = ISTSC+JFLD-1 + ENDDO + + IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN + CALL EFTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) + ELSEIF(IF_UV_G > 0) THEN + CALL EFTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& + & KPTRGP=IPTRGP,PGP=PGP) + ELSEIF(IF_SCALARS_G > 0) THEN + CALL EFTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP,& + & AUX_PROC=AUX_PROC) + ENDIF + CALL ELTDIR_CTL(IF_FS,IF_UV,IF_SCALARS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& + & PSPMEANU=PMEANU,PSPMEANV=PMEANV,AUX_PROC=AUX_PROC) + ENDDO +ELSE + + ! No splitting of fields, transform done in one go + + CALL EFTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,IF_GPB,& + & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& + & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& + & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2,& + & AUX_PROC=AUX_PROC) + + CALL ELTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& + & PSPMEANU=PMEANU,PSPMEANV=PMEANV,& + & AUX_PROC=AUX_PROC) + +ENDIF +IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTL_MOD:EDIR_TRANS_CTL',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EDIR_TRANS_CTL +END MODULE EDIR_TRANS_CTL_MOD diff --git a/src/etrans/etrans/internal/edir_trans_ctlad_mod.F90 b/src/etrans/etrans/internal/edir_trans_ctlad_mod.F90 new file mode 100644 index 000000000..34de8eed4 --- /dev/null +++ b/src/etrans/etrans/internal/edir_trans_ctlad_mod.F90 @@ -0,0 +1,194 @@ +MODULE EDIR_TRANS_CTLAD_MOD +CONTAINS +SUBROUTINE EDIR_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PMEANU,PMEANV) + +!**** *EDIR_TRANS_CTLAD* - Control routine for direct spectral transform-adj. + +! Purpose. +! -------- +! Control routine for the direct spectral transform + +!** Interface. +! ---------- +! CALL EDIR_TRANS_CTLAD(...) + +! Explicit arguments : +! -------------------- +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity +! PSPDIV(:,:) - spectral divergence +! PSPSCALAR(:,:) - spectral scalarvalued fields +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! PGP(:,:,:) - gridpoint fields + +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! u : KF_UV_G fields +! v : KF_UV_G fields +! scalar fields : KF_SCALARS_G fields + +! Method. +! ------- + +! Externals. SHUFFLE - reshuffle fields for load balancing +! ---------- FIELD_SPLIT - split fields in NPROMATR packets +! ELTDIR_CTLAD - control of Legendre transform +! EFTDIR_CTLAD - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 01-01-03 +! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NPROMATR +!USE TPM_TRANS +!USE TPM_DISTR + +USE SHUFFLE_MOD ,ONLY : SHUFFLE +USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT +USE ELTDIR_CTLAD_MOD ,ONLY : ELTDIR_CTLAD +USE EFTDIR_CTLAD_MOD ,ONLY : EFTDIR_CTLAD + +IMPLICIT NONE + +! Declaration of arguments + +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP +INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANV(:) + +! Local variables + +INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) +INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) +INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) +INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G +INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP +INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Perform transform + +IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTLAD_MOD:EDIR_TRANS_CTLAD',0,ZHOOK_HANDLE) +IF_GPB = 2*KF_UV_G+KF_SCALARS_G +IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN + + ! Fields to be split into packets + + CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & + & KVSETUV,KVSETSC) + + IBLKS=(IF_GPB-1)/NPROMATR+1 + + DO JBLK=1,IBLKS + + CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& + & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& + & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) + + IF_FS = 2*IF_UV + IF_SCALARS + IF_GP = 2*IF_UV_G+IF_SCALARS_G + DO JFLD=1,IF_UV_G + IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) + IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) + ENDDO + DO JFLD=1,IF_SCALARS_G + IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) + ENDDO + DO JFLD=1,IF_UV + IPTRSPUV(JFLD) = ISTUV+JFLD-1 + ENDDO + DO JFLD=1,IF_SCALARS + IPTRSPSC(JFLD) = ISTSC+JFLD-1 + ENDDO + + CALL ELTDIR_CTLAD(IF_FS,IF_UV,IF_SCALARS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& + & PSPMEANU=PMEANU,PSPMEANV=PMEANV) + IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN + CALL EFTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& + & PGP=PGP) + ELSEIF(IF_UV_G > 0) THEN + CALL EFTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& + & KPTRGP=IPTRGP,PGP=PGP) + ELSEIF(IF_SCALARS_G > 0) THEN + CALL EFTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& + & PGP=PGP) + ENDIF + ENDDO + +ELSE + + ! No splitting of fields, transform done in one go + + CALL ELTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& + & PSPMEANU=PMEANU,PSPMEANV=PMEANV) + + CALL EFTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,IF_GPB,& + & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& + & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& + & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) +ENDIF +IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTLAD_MOD:EDIR_TRANS_CTLAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EDIR_TRANS_CTLAD +END MODULE EDIR_TRANS_CTLAD_MOD diff --git a/src/etrans/etrans/internal/edist_spec_control_mod.F90 b/src/etrans/etrans/internal/edist_spec_control_mod.F90 new file mode 100644 index 000000000..ce55ba949 --- /dev/null +++ b/src/etrans/etrans/internal/edist_spec_control_mod.F90 @@ -0,0 +1,3 @@ +MODULE EDIST_SPEC_CONTROL_MOD + ! dead code - merged with DIST_SPEC_CONTROL_MOD +END MODULE EDIST_SPEC_CONTROL_MOD diff --git a/src/etrans/etrans/internal/efsc_mod.F90 b/src/etrans/etrans/internal/efsc_mod.F90 new file mode 100644 index 000000000..77ab4716e --- /dev/null +++ b/src/etrans/etrans/internal/efsc_mod.F90 @@ -0,0 +1,110 @@ +MODULE EFSC_MOD +CONTAINS +SUBROUTINE EFSC(KGL,KF_UV,KF_SCALARS,KF_SCDERS,& + & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) + +!**** *FSC - Division by a*cos(theta), east-west derivatives + +! Purpose. +! -------- +! In Fourier space divide u and v and all north-south +! derivatives by a*cos(theta). Also compute east-west derivatives +! of u,v,thermodynamic, passiv scalar variables and surface +! pressure. + +!** Interface. +! ---------- +! CALL FSC(..) +! Explicit arguments : PUV - u and v +! -------------------- PSCALAR - scalar valued varaibles +! PNSDERS - N-S derivative of S.V.V. +! PEWDERS - E-W derivative of S.V.V. +! PUVDERS - E-W derivative of u and v +! Method. +! ------- + +! Externals. None. +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 (From SC2FSC) +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_TRANS ,ONLY : LUVDER +USE TPM_DISTR ,ONLY : D, MYSETW +!USE TPM_FIELDS +USE TPM_GEOMETRY ,ONLY : G +USE TPMALD_GEO ,ONLY : GALD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) , INTENT(IN) :: KGL,KF_UV,KF_SCALARS,KF_SCDERS +REAL(KIND=JPRB) , INTENT(INOUT) :: PUV(:,:) +REAL(KIND=JPRB) , INTENT(IN ) :: PSCALAR(:,:) +REAL(KIND=JPRB) , INTENT(INOUT) :: PNSDERS(:,:) +REAL(KIND=JPRB) , INTENT( OUT) :: PEWDERS(:,:) +REAL(KIND=JPRB) , INTENT( OUT) :: PUVDERS(:,:) + +INTEGER(KIND=JPIM) :: IMEN,ISTAGTF + +INTEGER(KIND=JPIM) :: JF,IGLG,II,IR,JM +REAL(KIND=JPRB) :: ZIM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EFSC_MOD:EFSC',0,ZHOOK_HANDLE) +IGLG = D%NPTRLS(MYSETW)+KGL-1 +IMEN = G%NMEN(IGLG) +ISTAGTF = D%NSTAGTF(KGL) + +! ------------------------------------------------------------------ + +!* EAST-WEST DERIVATIVES +! --------------------- + +!* 2.1 U AND V. + +IF(LUVDER)THEN + DO JM=0,IMEN + ZIM=REAL(JM,JPRB)*GALD%EXWN + IR = ISTAGTF+2*JM+1 + II = IR+1 +! use unroll to provoke vectorization of outer loop +!cdir unroll=4 + DO JF=1,2*KF_UV + PUVDERS(JF,IR) = -PUV(JF,II)*ZIM + PUVDERS(JF,II) = PUV(JF,IR)*ZIM + ENDDO + ENDDO +ENDIF + +!* 2.2 SCALAR VARIABLES + +IF(KF_SCDERS > 0)THEN + DO JM=0,IMEN + ZIM=REAL(JM,JPRB)*GALD%EXWN + IR = ISTAGTF+2*JM+1 + II = IR+1 + DO JF=1,KF_SCALARS + PEWDERS(JF,IR) = -PSCALAR(JF,II)*ZIM + PEWDERS(JF,II) = PSCALAR(JF,IR)*ZIM + ENDDO + ENDDO +ENDIF +IF (LHOOK) CALL DR_HOOK('EFSC_MOD:EFSC',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EFSC +END MODULE EFSC_MOD diff --git a/src/etrans/etrans/internal/efscad_mod.F90 b/src/etrans/etrans/internal/efscad_mod.F90 new file mode 100644 index 000000000..4b335f4fa --- /dev/null +++ b/src/etrans/etrans/internal/efscad_mod.F90 @@ -0,0 +1,121 @@ +MODULE EFSCAD_MOD +CONTAINS +SUBROUTINE EFSCAD(KGL,KF_UV,KF_SCALARS,KF_SCDERS,& + & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) + +!**** *EFSCAD - Division by a*cos(theta), east-west derivatives - adjoint + +! Purpose. +! -------- +! In Fourier space divide u and v and all north-south +! derivatives by a*cos(theta). Also compute east-west derivatives +! of u,v,thermodynamic, passiv scalar variables and surface +! pressure. + +!** Interface. +! ---------- +! CALL EFSCAD(..) +! Explicit arguments : PUV - u and v +! -------------------- PSCALAR - scalar valued varaibles +! PNSDERS - N-S derivative of S.V.V. +! PEWDERS - E-W derivative of S.V.V. +! PUVDERS - E-W derivative of u and v +! Method. +! ------- + +! Externals. None. +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 (From SC2FSC) +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_TRANS ,ONLY : LUVDER +USE TPM_DISTR ,ONLY : D, MYSETW +!USE TPM_FIELDS +USE TPM_GEOMETRY ,ONLY : G + +USE TPMALD_GEO ,ONLY : GALD + +IMPLICIT NONE + +INTEGER(KIND=JPIM) , INTENT(IN) :: KGL,KF_UV,KF_SCALARS,KF_SCDERS +REAL(KIND=JPRB) , INTENT(INOUT) :: PUV(:,:) +REAL(KIND=JPRB) , INTENT(INOUT) :: PSCALAR(:,:) +REAL(KIND=JPRB) , INTENT(INOUT) :: PNSDERS(:,:) +REAL(KIND=JPRB) , INTENT(INOUT) :: PEWDERS(:,:) +REAL(KIND=JPRB) , INTENT(INOUT) :: PUVDERS(:,:) + +INTEGER(KIND=JPIM) :: IMEN,ISTAGTF + +INTEGER(KIND=JPIM) :: JF,IGLG,II,IR,JM + +REAL(KIND=JPRB) :: ZIM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EFSCAD_MOD:EFSCAD',0,ZHOOK_HANDLE) +IGLG = D%NPTRLS(MYSETW)+KGL-1 +IMEN = G%NMEN(IGLG) +ISTAGTF = D%NSTAGTF(KGL) + +! ------------------------------------------------------------------ + +!* 2. EAST-WEST DERIVATIVES +! --------------------- + +!* 2.1 U AND V. + +IF(LUVDER)THEN + DO JM=0,IMEN + + ZIM=REAL(JM,JPRB)*GALD%EXWN + + IR = ISTAGTF+2*JM+1 + II = IR+1 + DO JF=1,2*KF_UV + + PUV(JF,II) = PUV(JF,II) - ZIM*PUVDERS(JF,IR) + PUV(JF,IR) = PUV(JF,IR) + ZIM*PUVDERS(JF,II) + + PUVDERS(JF,IR) = 0.0_JPRB + PUVDERS(JF,II) = 0.0_JPRB + ENDDO + ENDDO +ENDIF + +!* 2.2 SCALAR VARIABLES + +IF(KF_SCDERS > 0)THEN + DO JM=0,IMEN + + ZIM=REAL(JM,JPRB)*GALD%EXWN + + IR = ISTAGTF+2*JM+1 + II = IR+1 + DO JF=1,KF_SCALARS + + PSCALAR(JF,II) = PSCALAR(JF,II) - ZIM* PEWDERS(JF,IR) + PSCALAR(JF,IR) = PSCALAR(JF,IR) + ZIM* PEWDERS(JF,II) + + PEWDERS(JF,IR) = 0.0_JPRB + PEWDERS(JF,II) = 0.0_JPRB + ENDDO + ENDDO +ENDIF +IF (LHOOK) CALL DR_HOOK('EFSCAD_MOD:EFSCAD',1,ZHOOK_HANDLE) +! ------------------------------------------------------------------ + +END SUBROUTINE EFSCAD +END MODULE EFSCAD_MOD diff --git a/src/etrans/etrans/internal/eftdir_ctl_mod.F90 b/src/etrans/etrans/internal/eftdir_ctl_mod.F90 new file mode 100644 index 000000000..212bcc956 --- /dev/null +++ b/src/etrans/etrans/internal/eftdir_ctl_mod.F90 @@ -0,0 +1,214 @@ +MODULE EFTDIR_CTL_MOD +CONTAINS +SUBROUTINE EFTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB, & + & KVSETUV,KVSETSC,KPTRGP,& + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2,AUX_PROC) + +!**** *EFTDIR_CTL - Direct Fourier transform control + +! Purpose. Control routine for Grid-point to Fourier transform +! -------- + +!** Interface. +! ---------- +! CALL FTDIR_CTL(..) + +! Explicit arguments : +! -------------------- +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! KF_GPB - total global number of output gridpoint fields +! PGP - gridpoint array +! KVSETUV - "B" set in spectral/fourier space for +! u and v variables +! KVSETSC - "B" set in spectral/fourier space for +! scalar variables +! KPTRGP - pointer array to fields in gridpoint space + +! Method. +! ------- + +! Externals. TRGTOL - transposition routine +! ---------- FOURIER_OUT - copy fourier data to Fourier buffer +! FTDIR - fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! G. Radnoti 01-03-13 adaptation to aladin (coupling) +! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 +! 19-11-01 : G. Radnoti bug corection by introducing cpl_int interface +! 02-09-30 : P. Smolikova AUX_PROC for d4 in NH +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR +USE TPM_DIM ,ONLY : R +USE TPM_TRANS ,ONLY : FOUBUF_IN +USE TPM_DISTR ,ONLY : D + +USE TRGTOL_MOD ,ONLY : TRGTOL +USE FOURIER_OUT_MOD ,ONLY : FOURIER_OUT +USE FTDIR_MOD ,ONLY : FTDIR +USE EXTPER_MOD ,ONLY : EXTPER +! + +IMPLICIT NONE + +! Dummy arguments + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP2(:,:,:) +EXTERNAL AUX_PROC +OPTIONAL AUX_PROC + +! Local variables +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER, CONTIGUOUS :: ZGTF(:,:) +REAL(KIND=JPRB) :: ZDUM +INTEGER(KIND=JPIM) :: IST,INUL,JGL,IGL,IBLEN +INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) +INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) +INTEGER(KIND=JPIM) :: IVSET(KF_GP) +INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Field distribution in Spectral/Fourier space + +IF (LHOOK) CALL DR_HOOK('EFTDIR_CTL_MOD:EFTDIR_CTL',0,ZHOOK_HANDLE) + +IF(PRESENT(KVSETUV)) THEN + IVSETUV(:) = KVSETUV(:) +ELSE + IVSETUV(:) = -1 +ENDIF +IVSETSC(:) = -1 +IF(PRESENT(KVSETSC)) THEN + IVSETSC(:) = KVSETSC(:) +ELSE + IOFF=0 + IF(PRESENT(KVSETSC2)) THEN + IFGP2=UBOUND(KVSETSC2,1) + IVSETSC(1:IFGP2)=KVSETSC2(:) + IOFF=IOFF+IFGP2 + ENDIF + IF(PRESENT(KVSETSC3A)) THEN + IFGP3A=UBOUND(KVSETSC3A,1) + DO J3=1,UBOUND(PGP3A,3) + IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) + IOFF=IOFF+IFGP3A + ENDDO + ENDIF + IF(PRESENT(KVSETSC3B)) THEN + IFGP3B=UBOUND(KVSETSC3B,1) + DO J3=1,UBOUND(PGP3B,3) + IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) + IOFF=IOFF+IFGP3B + ENDDO + ENDIF +ENDIF + +IST = 1 +IF(KF_UV_G > 0) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G +ENDIF +IF(KF_SCALARS_G > 0) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G +ENDIF + +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) +! Now, force the OS to allocate this shared array right now, not when it starts +! to be used which is an OPEN-MP loop, that would cause a threads +! synchronization lock : + IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN + ZGTF_HEAP(1,1)=HUGE(1._JPRB) + ENDIF + ZGTF => ZGTF_HEAP(:,:) +ENDIF + +! Transposition + +CALL GSTATS(158,0) +CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) +CALL GSTATS(158,1) +CALL GSTATS(106,0) + +! Periodization of auxiliary fields in x direction +IF(R%NNOEXTZL>0) THEN + CALL EXTPER(ZGTF,R%NDLON+R%NNOEXTZL,1,R%NDLON,KF_FS,D%NDGL_FS,D%NSTAGTF,0) +ELSE + IF (PRESENT(AUX_PROC)) THEN + CALL AUX_PROC(ZGTF,ZDUM,KF_FS,D%NLENGTF,1,D%NDGL_FS,0,.TRUE.,& + & D%NSTAGTF,INUL,INUL,INUL) + ENDIF +ENDIF + +! Fourier transform + +IBLEN=D%NLENGT0B*2*KF_FS +IF (ALLOCATED(FOUBUF_IN)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN + DEALLOCATE(FOUBUF_IN) + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! force allocation here + ENDIF +ELSE + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! force allocation here +ENDIF + +CALL GSTATS(1640,0) +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) +DO JGL=1,D%NDGL_FS + IGL = JGL + IF(KF_FS>0) THEN + CALL FTDIR(ZGTF,KF_FS,IGL) + ENDIF + +! Save Fourier data in FOUBUF_IN + + CALL FOURIER_OUT(ZGTF,KF_FS,IGL) +ENDDO +!$OMP END PARALLEL DO +CALL GSTATS(1640,1) +CALL GSTATS(106,1) +IF (LHOOK) CALL DR_HOOK('EFTDIR_CTL_MOD:EFTDIR_CTL',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EFTDIR_CTL +END MODULE EFTDIR_CTL_MOD diff --git a/src/etrans/etrans/internal/eftdir_ctlad_mod.F90 b/src/etrans/etrans/internal/eftdir_ctlad_mod.F90 new file mode 100644 index 000000000..09483e0a4 --- /dev/null +++ b/src/etrans/etrans/internal/eftdir_ctlad_mod.F90 @@ -0,0 +1,201 @@ +MODULE EFTDIR_CTLAD_MOD +CONTAINS +SUBROUTINE EFTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB, & + & KVSETUV,KVSETSC,KPTRGP,& + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) + +!**** *EFTDIR_CTLAD - Direct Fourier transform control - adjoint + +! Purpose. Control routine for Grid-point to Fourier transform +! -------- + +!** Interface. +! ---------- +! CALL EFTDIR_CTLAD(..) + +! Explicit arguments : +! -------------------- +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! PGP - gridpoint array +! KVSETUV - "B" set in spectral/fourier space for +! u and v variables +! KVSETSC - "B" set in spectral/fourier space for +! scalar variables +! KPTRGP - pointer array to fields in gridpoint space + +! Method. +! ------- + +! Externals. TRGTOL - transposition routine +! ---------- FOURIER_OUT - copy fourier data to Fourier buffer +! EFTDIRAD - fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 +! 19-11-01 G. Radnoti bug correction by introducing CPL_INT interface +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! R. El Khatib 05-03-15 remove HLOMP +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR +USE TPM_DISTR ,ONLY : D + +USE TRLTOG_MOD ,ONLY : TRLTOG +USE FOURIER_OUTAD_MOD ,ONLY : FOURIER_OUTAD +USE EFTDIRAD_MOD ,ONLY : EFTDIRAD +! + +IMPLICIT NONE + +! Dummy arguments + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP2(:,:,:) + +! Local variables +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER :: ZGTF(:,:) + +INTEGER(KIND=JPIM) :: IST +INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) +INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) +INTEGER(KIND=JPIM) :: IVSET(KF_GP) +INTEGER(KIND=JPIM) :: JGL,IGL,J1,J2 +INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Field distribution in Spectral/Fourier space + +IF (LHOOK) CALL DR_HOOK('EFTDIR_CTLAD_MOD:EFTDIR_CTLAD',0,ZHOOK_HANDLE) +CALL GSTATS(133,0) + +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) + ZGTF => ZGTF_HEAP(:,:) +ENDIF + +ZGTF(:,:)=0._JPRB + +IF(PRESENT(KVSETUV)) THEN + IVSETUV(:) = KVSETUV(:) +ELSE + IVSETUV(:) = -1 +ENDIF +IF(PRESENT(KVSETSC)) THEN + IVSETSC(:) = KVSETSC(:) +ELSE + IVSETSC(:) = -1 +ENDIF +IST = 1 +IF(KF_UV_G > 0) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G +ENDIF +IF(KF_SCALARS_G > 0) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G +ENDIF + +CALL GSTATS(1642,0) +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) +DO JGL=1,D%NDGL_FS + IGL = JGL + CALL FOURIER_OUTAD(ZGTF,KF_FS,IGL) + +! Fourier transform + + IF(KF_FS>0) THEN + CALL EFTDIRAD(ZGTF,KF_FS,IGL) + ENDIF +ENDDO +!$OMP END PARALLEL DO +CALL GSTATS(1642,1) +CALL GSTATS(133,1) + +! Transposition + +CALL GSTATS(183,0) +IF(PRESENT(KVSETUV)) THEN + IVSETUV(:) = KVSETUV(:) +ELSE + IVSETUV(:) = -1 +ENDIF +IVSETSC(:) = -1 +IF(PRESENT(KVSETSC)) THEN + IVSETSC(:) = KVSETSC(:) +ELSE + IOFF=0 + IF(PRESENT(KVSETSC2)) THEN + IFGP2=UBOUND(KVSETSC2,1) + IVSETSC(1:IFGP2)=KVSETSC2(:) + IOFF=IOFF+IFGP2 + ENDIF + IF(PRESENT(KVSETSC3A)) THEN + IFGP3A=UBOUND(KVSETSC3A,1) + DO J3=1,UBOUND(PGP3A,3) + IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) + IOFF=IOFF+IFGP3A + ENDDO + ENDIF + IF(PRESENT(KVSETSC3B)) THEN + IFGP3B=UBOUND(KVSETSC3B,1) + DO J3=1,UBOUND(PGP3B,3) + IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) + IOFF=IOFF+IFGP3B + ENDDO + ENDIF +ENDIF + +IST = 1 +IF(KF_UV_G > 0) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G +ENDIF +IF(KF_SCALARS_G > 0) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G +ENDIF +CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) + +CALL GSTATS(183,1) +IF (LHOOK) CALL DR_HOOK('EFTDIR_CTLAD_MOD:EFTDIR_CTLAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EFTDIR_CTLAD +END MODULE EFTDIR_CTLAD_MOD diff --git a/src/etrans/etrans/internal/eftdirad_mod.F90 b/src/etrans/etrans/internal/eftdirad_mod.F90 new file mode 100644 index 000000000..10a7f2259 --- /dev/null +++ b/src/etrans/etrans/internal/eftdirad_mod.F90 @@ -0,0 +1,119 @@ +MODULE EFTDIRAD_MOD +CONTAINS +SUBROUTINE EFTDIRAD(PREEL,KFIELDS,KGL) + +!**** *EFTDIRAD - Direct Fourier transform + +! Purpose. Routine for Grid-point to Fourier transform - adjoint +! -------- + +!** Interface. +! ---------- +! CALL EFTDIRAD(..) + +! Explicit arguments : PREEL - Fourier/grid-point array +! -------------------- KFIELDS - number of fields + +! Method. +! ------- + +! Externals. FFT992 - FFT routine +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! R. El Khatib 01-Sep-2015 support for FFTW transforms +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM, JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DISTR ,ONLY : D, MYSETW +!USE TPM_TRANS +USE TPM_GEOMETRY ,ONLY : G +USE TPM_FFT ,ONLY : T, TB +USE BLUESTEIN_MOD ,ONLY : BLUESTEIN_FFT +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, EXEC_FFTW +#endif +USE TPM_DIM ,ONLY : R +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL +REAL(KIND=JPRB), INTENT(INOUT) :: PREEL(:,:) + +INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN +INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE +REAL(KIND=JPRB) :: ZNORM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EFTDIRAD_MOD:EFTDIRAD',0,ZHOOK_HANDLE) + +ITYPE = 1 +IJUMP = 1 +IGLG = D%NPTRLS(MYSETW)+KGL-1 +ILOEN = G%NLOEN(IGLG) +IST = 2*(G%NMEN(IGLG)+1)+1 +ILEN = ILOEN+3-IST +IOFF = D%NSTAGTF(KGL)+1 + +DO JJ=1,ILEN + DO JF=1,KFIELDS + PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB + ENDDO +ENDDO +DO JJ=1,1 + DO JF=1,KFIELDS + PREEL(JF,IOFF-1+JJ) = 2.0_JPRB * PREEL(JF,IOFF-1+JJ) + ENDDO +ENDDO + +#ifdef WITH_FFTW +IF( .NOT. TW%LFFTW )THEN +#endif + + IF( T%LUSEFFT992(KGL) )THEN + + CALL FFT992(PREEL(1,IOFF),T%TRIGS(1,KGL),& + &T%NFAX(1,KGL),KFIELDS,IJUMP,ILOEN,KFIELDS,ITYPE) + + ELSE + + CALL BLUESTEIN_FFT(TB,ILOEN,ITYPE,KFIELDS,PREEL(1:KFIELDS,IOFF:IOFF+ICLEN-1)) + + ENDIF + +#ifdef WITH_FFTW +ELSE + + IRLEN=G%NLOEN(IGLG)+R%NNOEXTZL + ICLEN=(IRLEN/2+1)*2 + CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) + +ENDIF +#endif + + + ! Change of metric (not in forward routine) +ZNORM=1.0_JPRB/(2.0_JPRB*REAL(ILOEN,JPRB)) +DO JJ=1,ILOEN + DO JF=1,KFIELDS + PREEL(JF,IOFF-1+JJ) = ZNORM * PREEL(JF,IOFF-1+JJ) + ENDDO +ENDDO +IF (LHOOK) CALL DR_HOOK('EFTDIRAD_MOD:EFTDIRAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EFTDIRAD +END MODULE EFTDIRAD_MOD diff --git a/src/etrans/etrans/internal/eftinv_ctl_mod.F90 b/src/etrans/etrans/internal/eftinv_ctl_mod.F90 new file mode 100644 index 000000000..3dd9d5352 --- /dev/null +++ b/src/etrans/etrans/internal/eftinv_ctl_mod.F90 @@ -0,0 +1,273 @@ +MODULE EFTINV_CTL_MOD +CONTAINS +SUBROUTINE EFTINV_CTL(KF_UV_G,KF_SCALARS_G,& + & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) + +!**** *EFTINV_CTL - Inverse Fourier transform control + +! Purpose. Control routine for Fourier to Gridpoint transform +! -------- + +!** Interface. +! ---------- +! CALL EFTINV_CTL(..) + +! Explicit arguments : +! -------------------- +! PGP - gridpoint array +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! KF_SCDERS - local number of derivatives of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! KF_OUT_LT - total number of fields coming out from inverse LT +! KVSETUV - "B" set in spectral/fourier space for +! u and v variables +! KVSETSC - "B" set in spectral/fourier space for +! scalar variables +! KPTRGP - pointer array to fi3elds in gridpoint space + +! Method. +! ------- + +! Externals. TRLTOG - transposition routine +! ---------- FOURIER_IN - copy fourier data from Fourier buffer +! FTINV - fourier transform +! FSC - Fourier space computations + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! G. Hello : 03-10-14 old way of calling +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! O.Spaniel Oct-2004 phasing for AL29 +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR +USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP +USE TPM_DISTR ,ONLY : D + +USE FOURIER_IN_MOD ,ONLY : FOURIER_IN +USE EFSC_MOD ,ONLY : EFSC +USE FTINV_MOD ,ONLY : FTINV +USE TRLTOG_MOD ,ONLY : TRLTOG +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP2(:,:,:) + +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER :: ZGTF(:,:) +REAL(KIND=JPRB),TARGET :: ZDUM(1,D%NLENGTF) +REAL(KIND=JPRB),POINTER :: ZUV(:,:) +REAL(KIND=JPRB),POINTER :: ZSCALAR(:,:) +REAL(KIND=JPRB),POINTER :: ZNSDERS(:,:) +REAL(KIND=JPRB),POINTER :: ZEWDERS(:,:) +REAL(KIND=JPRB),POINTER :: ZUVDERS(:,:) + +INTEGER(KIND=JPIM) :: IST +INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) +INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) +INTEGER(KIND=JPIM) :: IVSET(KF_GP) +INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! 1. Copy Fourier data to local array + +IF (LHOOK) CALL DR_HOOK('EFTINV_CTL_MOD:EFTINV_CTL',0,ZHOOK_HANDLE) +CALL GSTATS(107,0) + +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) +! Now, force the OS to allocate this shared array right now, not when it starts +! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : + IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN + ZGTF_HEAP(1,1)=HUGE(1._JPRB) + ENDIF + ZGTF => ZGTF_HEAP(:,:) +ENDIF + +IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN + IST = 1 + IF(LVORGP) THEN + IST = IST+KF_UV + ENDIF + IF(LDIVGP) THEN + IST = IST+KF_UV + ENDIF + ZUV => ZGTF(IST:IST+2*KF_UV-1,:) + IST = IST+2*KF_UV + ZSCALAR => ZGTF(IST:IST+KF_SCALARS-1,:) + IST = IST+KF_SCALARS + ZNSDERS => ZGTF(IST:IST+KF_SCDERS-1,:) + IST = IST+KF_SCDERS + IF(LUVDER) THEN + ZUVDERS => ZGTF(IST:IST+2*KF_UV-1,:) + IST = IST+2*KF_UV + ELSE + ZUVDERS => ZDUM(1:1,:) + ENDIF + IF(KF_SCDERS > 0) THEN + ZEWDERS => ZGTF(IST:IST+KF_SCDERS-1,:) + ELSE + ZEWDERS => ZDUM(1:1,:) + ENDIF +ENDIF + +CALL GSTATS(1639,0) +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) +DO JGL=1,D%NDGL_FS + IGL = JGL + CALL FOURIER_IN(ZGTF,KF_OUT_LT,IGL) + +! 2. Fourier space computations + + IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN + CALL EFSC(IGL,KF_UV,KF_SCALARS,KF_SCDERS,& + & ZUV,ZSCALAR,ZNSDERS,ZEWDERS,ZUVDERS) + ENDIF + +! 3. Fourier transform + IF(KF_FS > 0) THEN + CALL FTINV(ZGTF,KF_FS,IGL) + ENDIF +ENDDO +!$OMP END PARALLEL DO +CALL GSTATS(1639,1) + +IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN + NULLIFY(ZUV) + NULLIFY(ZSCALAR) + NULLIFY(ZNSDERS) + NULLIFY(ZUVDERS) + NULLIFY(ZEWDERS) +ENDIF +CALL GSTATS(107,1) + +! 4. Transposition + +IF(PRESENT(KVSETUV)) THEN + IVSETUV(:) = KVSETUV(:) +ELSE + IVSETUV(:) = -1 +ENDIF +IVSETSC(:)=-1 +IF(PRESENT(KVSETSC)) THEN + IVSETSC(:) = KVSETSC(:) +ELSEIF(PRESENT(KVSETSC2).OR.PRESENT(KVSETSC3A)& + & .OR.PRESENT(KVSETSC3B)) THEN + IOFF=0 + IF(PRESENT(KVSETSC2)) THEN + IFGP2=UBOUND(KVSETSC2,1) + IVSETSC(1:IFGP2)=KVSETSC2(:) + IOFF=IOFF+IFGP2 + ENDIF + IF(PRESENT(KVSETSC3A)) THEN + IFGP3A=UBOUND(KVSETSC3A,1) + IGP3APAR=UBOUND(PGP3A,3) + IF(LSCDERS) IGP3APAR=IGP3APAR/3 + DO J3=1,IGP3APAR + IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) + IOFF=IOFF+IFGP3A + ENDDO + ENDIF + IF(PRESENT(KVSETSC3B)) THEN + IFGP3B=UBOUND(KVSETSC3B,1) + IGP3BPAR=UBOUND(PGP3B,3) + IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 + DO J3=1,IGP3BPAR + IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) + IOFF=IOFF+IFGP3B + ENDDO + ENDIF + IF(IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN + WRITE(NERR,*)'FTINV:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G + CALL ABORT_TRANS('FTINV_CTL_MOD:IOFF /= KF_SCALARS_G') + ENDIF +ENDIF + +IST = 1 +IF(KF_UV_G > 0) THEN + IF( LVORGP) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + ENDIF + IF( LDIVGP) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + ENDIF + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G +ENDIF +IF(KF_SCALARS_G > 0) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G + IF(LSCDERS) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G + ENDIF +ENDIF +IF(KF_UV_G > 0 .AND. LUVDER) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G +ENDIF +IF(KF_SCALARS_G > 0) THEN + IF(LSCDERS) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G + ENDIF +ENDIF + +CALL GSTATS(157,0) +CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) +CALL GSTATS(157,1) + +IF (LHOOK) CALL DR_HOOK('EFTINV_CTL_MOD:EFTINV_CTL',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EFTINV_CTL +END MODULE EFTINV_CTL_MOD diff --git a/src/etrans/etrans/internal/eftinv_ctlad_mod.F90 b/src/etrans/etrans/internal/eftinv_ctlad_mod.F90 new file mode 100644 index 000000000..fd1fc5e57 --- /dev/null +++ b/src/etrans/etrans/internal/eftinv_ctlad_mod.F90 @@ -0,0 +1,295 @@ +MODULE EFTINV_CTLAD_MOD +CONTAINS +SUBROUTINE EFTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& + & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & + & KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) + +!**** *EFTINV_CTLAD - Inverse Fourier transform control - adjoint + +! Purpose. Control routine for Fourier to Gridpoint transform +! -------- + +!** Interface. +! ---------- +! CALL EFTINV_CTLAD(..) + +! Explicit arguments : +! -------------------- +! PGP - gridpoint array +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! KF_SCDERS - local number of derivatives of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! KF_OUT_LT - total number of fields coming out from inverse LT +! KVSETUV - "B" set in spectral/fourier space for +! u and v variables +! KVSETSC - "B" set in spectral/fourier space for +! scalar variables +! KPTRGP - pointer array to fi3elds in gridpoint space + +! Method. +! ------- + +! Externals. TRLTOG - transposition routine +! ---------- FOURIER_IN - copy fourier data from Fourier buffer +! FTINV - fourier transform +! FSC - Fourier space computations + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR +USE TPM_DIM ,ONLY : R +USE TPM_TRANS ,ONLY : FOUBUF, LDIVGP, LSCDERS, LUVDER, LVORGP +USE TPM_DISTR ,ONLY : D + +USE FOURIER_INAD_MOD ,ONLY : FOURIER_INAD +USE EFSCAD_MOD ,ONLY : EFSCAD +USE EFTINVAD_MOD ,ONLY : EFTINVAD +USE TRGTOL_MOD ,ONLY : TRGTOL +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +USE EXTPER_MOD ,ONLY : EXTPER +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS +INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP2(:,:,:) + +! ------------------------------------------------------------------ + +REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) +REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) +REAL(KIND=JPRB),POINTER :: ZGTF(:,:) +REAL(KIND=JPRB),TARGET :: ZDUM(1,D%NLENGTF) +REAL(KIND=JPRB),POINTER :: ZUV(:,:) +REAL(KIND=JPRB),POINTER :: ZSCALAR(:,:) +REAL(KIND=JPRB),POINTER :: ZNSDERS(:,:) +REAL(KIND=JPRB),POINTER :: ZEWDERS(:,:) +REAL(KIND=JPRB),POINTER :: ZUVDERS(:,:) + +INTEGER(KIND=JPIM) :: IST, IBLEN +INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) +INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) +INTEGER(KIND=JPIM) :: IVSET(KF_GP) +INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! 4. Transposition + +IF (LHOOK) CALL DR_HOOK('EFTINV_CTLAD_MOD:EFTINV_CTLAD',0,ZHOOK_HANDLE) + +IF (NSTACK_MEMORY_TR == 1) THEN + ZGTF => ZGTF_STACK(:,:) +ELSE + ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) + ZGTF => ZGTF_HEAP(:,:) +ENDIF + +ZGTF(:,:)=0._JPRB + +IF(PRESENT(KVSETUV)) THEN + IVSETUV(:) = KVSETUV(:) +ELSE + IVSETUV(:) = -1 +ENDIF + +IVSETSC(:)=-1 +IF(PRESENT(KVSETSC)) THEN + IVSETSC(:) = KVSETSC(:) +ELSE + IOFF=0 + IF(PRESENT(KVSETSC2)) THEN + IFGP2=UBOUND(KVSETSC2,1) + IVSETSC(1:IFGP2)=KVSETSC2(:) + IOFF=IOFF+IFGP2 + ENDIF + IF(PRESENT(KVSETSC3A)) THEN + IFGP3A=UBOUND(KVSETSC3A,1) + IGP3APAR=UBOUND(PGP3A,3) + IF(LSCDERS) IGP3APAR=IGP3APAR/3 + DO J3=1,IGP3APAR + IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) + IOFF=IOFF+IFGP3A + ENDDO + ENDIF + IF(PRESENT(KVSETSC3B)) THEN + IFGP3B=UBOUND(KVSETSC3B,1) + IGP3BPAR=UBOUND(PGP3B,3) + IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 + DO J3=1,IGP3BPAR + IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) + IOFF=IOFF+IFGP3B + ENDDO + ENDIF + IF(IOFF /= KF_SCALARS_G ) THEN + WRITE(NERR,*)'FTINV_CTLAD:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G + CALL ABORT_TRANS('FTINV_CTLAD_MOD:IOFF /= KF_SCALARS_G') + ENDIF +ENDIF + +IST = 1 +IF(KF_UV_G > 0) THEN + IF( LVORGP) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + ENDIF + IF( LDIVGP) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + ENDIF + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G +ENDIF +IF(KF_SCALARS_G > 0) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G + IF(LSCDERS) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G + ENDIF +ENDIF +IF(KF_UV_G > 0 .AND. LUVDER) THEN + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G + IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) + IST = IST+KF_UV_G +ENDIF +IF(KF_SCALARS_G > 0) THEN + IF(LSCDERS) THEN + IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) + IST = IST+KF_SCALARS_G + ENDIF +ENDIF + +CALL GSTATS(182,0) +CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) +CALL GSTATS(182,1) + +! Periodization of auxiliary fields in x direction +IF(R%NNOEXTZL>0) THEN + CALL EXTPER(ZGTF,R%NDLON+R%NNOEXTZL,1,R%NDLON,KF_FS,D%NDGL_FS,D%NSTAGTF,0) +ENDIF + + +! 3. Fourier transform + +IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN + IST = 1 + IF(LVORGP) THEN + IST = IST+KF_UV + ENDIF + IF(LDIVGP) THEN + IST = IST+KF_UV + ENDIF + ZUV => ZGTF(IST:IST+2*KF_UV-1,:) + IST = IST+2*KF_UV + ZSCALAR => ZGTF(IST:IST+KF_SCALARS-1,:) + IST = IST+KF_SCALARS + ZNSDERS => ZGTF(IST:IST+KF_SCDERS-1,:) + IST = IST+KF_SCDERS + IF(LUVDER) THEN + ZUVDERS => ZGTF(IST:IST+2*KF_UV-1,:) + IST = IST+2*KF_UV + ELSE + ZUVDERS => ZDUM(1:1,:) + ENDIF + IF(KF_SCDERS > 0) THEN + ZEWDERS => ZGTF(IST:IST+KF_SCDERS-1,:) + ELSE + ZEWDERS => ZDUM(1:1,:) + ENDIF +ENDIF + +IBLEN = D%NLENGT0B*2*KF_OUT_LT +IF (ALLOCATED(FOUBUF)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN + DEALLOCATE(FOUBUF) + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + FOUBUF(1)=0._JPRB ! force allocation here + ENDIF +ELSE + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + FOUBUF(1)=0._JPRB ! force allocation here +ENDIF + +CALL GSTATS(132,0) + +CALL GSTATS(1641,0) +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) +DO JGL=1,D%NDGL_FS + IGL = JGL + IF(KF_FS > 0) THEN + CALL EFTINVAD(ZGTF,KF_FS,IGL) + ENDIF + +! 2. Fourier space computations + + IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN + CALL EFSCAD(IGL,KF_UV,KF_SCALARS,KF_SCDERS,& + & ZUV,ZSCALAR,ZNSDERS,ZEWDERS,ZUVDERS) + ENDIF + +! 1. Copy Fourier data to local array + + CALL FOURIER_INAD(ZGTF,KF_OUT_LT,IGL) + +ENDDO +!$OMP END PARALLEL DO +CALL GSTATS(1641,1) + +IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN + NULLIFY(ZUV) + NULLIFY(ZSCALAR) + NULLIFY(ZNSDERS) + NULLIFY(ZUVDERS) + NULLIFY(ZEWDERS) +ENDIF + +CALL GSTATS(132,1) +IF (LHOOK) CALL DR_HOOK('EFTINV_CTLAD_MOD:EFTINV_CTLAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EFTINV_CTLAD +END MODULE EFTINV_CTLAD_MOD diff --git a/src/etrans/etrans/internal/eftinvad_mod.F90 b/src/etrans/etrans/internal/eftinvad_mod.F90 new file mode 100644 index 000000000..b1c1df4ff --- /dev/null +++ b/src/etrans/etrans/internal/eftinvad_mod.F90 @@ -0,0 +1,128 @@ +MODULE EFTINVAD_MOD +CONTAINS +SUBROUTINE EFTINVAD(PREEL,KFIELDS,KGL) + +!**** *EFTINVAD - Inverse Fourier transform - adjoint + +! Purpose. Routine for Fourier to Grid-point transform +! -------- + +!** Interface. +! ---------- +! CALL EFTINVAD(..) + +! Explicit arguments : PREEL - Fourier/grid-point array +! -------------------- KFIELDS - number of fields + +! Method. +! ------- + +! Externals. FFT992 - FFT routine +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-03-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 01-Sep-2015 support for FFTW transforms +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM, JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DISTR ,ONLY : D, MYSETW +USE TPM_DIM ,ONLY : R +USE TPM_GEOMETRY ,ONLY : G +USE TPM_FFT ,ONLY : T, TB +USE BLUESTEIN_MOD ,ONLY : BLUESTEIN_FFT +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, EXEC_FFTW +#endif +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL +REAL(KIND=JPRB), INTENT(OUT) :: PREEL(:,:) + +INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN +INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE + +REAL(KIND=JPRB) :: ZNORM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EFTINVAD_MOD:EFTINVAD',0,ZHOOK_HANDLE) + +ITYPE =-1 +IJUMP = 1 +IGLG = D%NPTRLS(MYSETW)+KGL-1 +ILOEN = G%NLOEN(IGLG)+R%NNOEXTZL +IST = 2*(G%NMEN(IGLG)+1)+1 +ILEN = ILOEN+3-IST +IOFF = D%NSTAGTF(KGL)+1 + +! ! Change of metric (not in forward routine) + +#ifdef WITH_FFTW +IF( .NOT. TW%LFFTW )THEN +#endif + + IF( T%LUSEFFT992(KGL) )THEN + + CALL FFT992(PREEL(1,IOFF),T%TRIGS(1,KGL),& + &T%NFAX(1,KGL),KFIELDS,IJUMP,ILOEN,KFIELDS,ITYPE) + + ELSE + + CALL BLUESTEIN_FFT(TB,ILOEN,ITYPE,KFIELDS,PREEL(1:KFIELDS,IOFF:IOFF+ICLEN-1)) + DO JJ=1,ICLEN + DO JF=1,KFIELDS + PREEL(JF,IOFF-1+JJ)=PREEL(JF,IOFF-1+JJ)/REAL(ILOEN,JPRB) + ENDDO + ENDDO + + ENDIF + +#ifdef WITH_FFTW +ELSE + + IRLEN=G%NLOEN(IGLG)+R%NNOEXTZL + ICLEN=(IRLEN/2+1)*2 + CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) + +ENDIF +#endif + +ZNORM=2.0_JPRB*REAL(ILOEN,JPRB) +DO JJ=1,1 + DO JF=1,KFIELDS + PREEL(JF,IOFF-1+JJ) = (ZNORM/2.0_JPRB) * PREEL(JF,IOFF-1+JJ) + ENDDO +ENDDO + +DO JJ=3,ILOEN+1 + DO JF=1,KFIELDS + PREEL(JF,IOFF-1+JJ) = ZNORM * PREEL(JF,IOFF-1+JJ) + ENDDO +ENDDO + +DO JJ=1,ILEN + DO JF=1,KFIELDS + PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB + ENDDO +ENDDO +IF (LHOOK) CALL DR_HOOK('EFTINVAD_MOD:EFTINVAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EFTINVAD +END MODULE EFTINVAD_MOD diff --git a/src/etrans/etrans/internal/egath_spec_control_mod.F90 b/src/etrans/etrans/internal/egath_spec_control_mod.F90 new file mode 100644 index 000000000..c67b315aa --- /dev/null +++ b/src/etrans/etrans/internal/egath_spec_control_mod.F90 @@ -0,0 +1,201 @@ +MODULE EGATH_SPEC_CONTROL_MOD +CONTAINS +SUBROUTINE EGATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& + & KSMAX,KSPEC2,KSPEC2_G,KPOSSP,KDIM0G,KCPL2M,LDZA0IP) + +!**** *GATH_SPEC_CONTROL* - Gather global spectral array from processors + +! Purpose. +! -------- +! Routine for gathering spectral array + +!** Interface. +! ---------- +! CALL GATH_SPEC_CONTROL(...) + +! Explicit arguments : +! -------------------- +! PSPECG(:,:) - Global spectral array +! KFGATHG - Global number of fields to be distributed +! KTO(:) - Processor responsible for distributing each field +! KVSET(:) - "B-Set" for each field +! PSPEC(:,:) - Local spectral array + +! ------------------------------------------------------------------ + + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & + & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD + +USE TPM_DISTR ,ONLY : MTAGDISTSP, NPRCIDS, NPRTRW, MYSETV, MYPROC, NPROC +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +USE SET2PE_MOD ,ONLY : SET2PE + +IMPLICIT NONE + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG +INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) +LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD +INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX +INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 +INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2_G +INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KCPL2M(0:) +LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP + +REAL(KIND=JPRB) :: ZFLD(KSPEC2,KFGATHG) +REAL(KIND=JPRB),ALLOCATABLE :: ZRECV(:,:) +INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,IBSET,ILEN,JA,ISND +INTEGER(KIND=JPIM) :: IRCV,ISP,ILENR,ISTA,ISTP,ISENDREQ(KFGATHG),IPOS0,JNM +INTEGER(KIND=JPIM) :: IDIST(KSPEC2_G),IMYFIELDS + +! ------------------------------------------------------------------ + + +CALL ABORT_TRANS('EGATH_SPEC_CONTROL:DEAD CODE') +!GATHER SPECTRAL ARRAY + +IF( NPROC == 1 ) THEN + CALL GSTATS(1644,0) + IF(LDIM1_IS_FLD) THEN +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) + DO JM=1,KSPEC2_G + DO JFLD=1,KFGATHG + PSPECG(JFLD,JM) =PSPEC(JFLD,JM) + ENDDO + ENDDO +!$OMP END PARALLEL DO + ELSE +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) + DO JFLD=1,KFGATHG + DO JM=1,KSPEC2_G + PSPECG(JM,JFLD) =PSPEC(JM,JFLD) + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + CALL GSTATS(1644,1) +ELSE + IMYFIELDS = 0 + DO JFLD=1,KFGATHG + IF(KTO(JFLD) == MYPROC) THEN + IMYFIELDS = IMYFIELDS+1 + ENDIF + ENDDO + IF(IMYFIELDS>0) THEN + ALLOCATE(ZRECV(KSPEC2_G,IMYFIELDS)) + II = 0 + CALL GSTATS(1804,0) + DO JM=0,KSMAX + DO JN=0,KCPL2M(JM)/2-1 + IDIST(II+1) = KDIM0G(JM)+4*JN + IDIST(II+2) = KDIM0G(JM)+4*JN+1 + IDIST(II+3) = KDIM0G(JM)+4*JN+2 + IDIST(II+4) = KDIM0G(JM)+4*JN+3 + II = II+4 + ENDDO + ENDDO + CALL GSTATS(1804,1) + ENDIF + + CALL GSTATS_BARRIER(788) + + !Send + CALL GSTATS(810,0) + IFLDS = 0 + IF(KSPEC2 > 0 )THEN + DO JFLD=1,KFGATHG + + IBSET = KVSET(JFLD) + IF( IBSET == MYSETV )THEN + + IFLDS = IFLDS+1 + ISND = KTO(JFLD) + ITAG = MTAGDISTSP+JFLD+17 + IF(LDIM1_IS_FLD) THEN + ZFLD(1:KSPEC2,IFLDS)=PSPEC(IFLDS,1:KSPEC2) + CALL MPL_SEND(ZFLD(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& + &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& + &CDSTRING='GATH_SPEC_CONTROL') + ELSE + CALL MPL_SEND(PSPEC(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& + &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& + &CDSTRING='GATH_SPEC_CONTROL') + ENDIF + ENDIF + ENDDO + ENDIF + + ! Recieve + IFLDR = 0 + DO JFLD=1,KFGATHG + IF(KTO(JFLD) == MYPROC) THEN + IBSET = KVSET(JFLD) + IFLDR = IFLDR+1 + DO JA=1,NPRTRW + ILEN = KPOSSP(JA+1)-KPOSSP(JA) + IF( ILEN > 0 )THEN + CALL SET2PE(IRCV,0,0,JA,IBSET) + ITAG = MTAGDISTSP+JFLD+17 + ISTA = KPOSSP(JA) + ISTP = ISTA+ILEN-1 + CALL MPL_RECV(ZRECV(ISTA:ISTP,IFLDR),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& + &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & + &CDSTRING='GATH_SPEC_CONTROL') + IF( ILENR /= ILEN )THEN + WRITE(0,'("GATH_SPEC_CONTROL: JFLD=",I4," JA=",I4," ILEN=",I10," ILENR=",I10)')& + &JFLD,JA,ILEN,ILENR + CALL ABORT_TRANS('GATH_SPEC_CONTROL:INVALID RECEIVE MESSAGE LENGTH') + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + ! Check for completion of sends + IF(KSPEC2 > 0 )THEN + DO JFLD=1,KFGATHG + IBSET = KVSET(JFLD) + IF( IBSET == MYSETV )THEN + CALL MPL_WAIT(ISENDREQ(JFLD), & + & CDSTRING='GATH_GRID_CTL: WAIT') + ENDIF + ENDDO + ENDIF + CALL GSTATS(810,1) + CALL GSTATS_BARRIER2(788) + + CALL GSTATS(1644,0) +!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JNM,II,JN,ISP) + DO JFLD=1,IMYFIELDS + IF(LDIM1_IS_FLD) THEN + DO JNM=1,KSPEC2_G + PSPECG(JFLD,JNM) = ZRECV(IDIST(JNM),JFLD) + ENDDO + ELSE + DO JNM=1,KSPEC2_G + PSPECG(JNM,JFLD) = ZRECV(IDIST(JNM),JFLD) + ENDDO + ENDIF + ENDDO +!$OMP END PARALLEL DO + CALL GSTATS(1644,1) + IF(ALLOCATED(ZRECV)) DEALLOCATE(ZRECV) + + !Synchronize processors + CALL GSTATS(785,0) + CALL MPL_BARRIER(CDSTRING='GATH_SPEC_CONTROL:') + CALL GSTATS(785,1) +ENDIF + +! ------------------------------------------------------------------ + +END SUBROUTINE EGATH_SPEC_CONTROL +END MODULE EGATH_SPEC_CONTROL_MOD + + diff --git a/src/etrans/etrans/internal/einv_trans_ctl_mod.F90 b/src/etrans/etrans/internal/einv_trans_ctl_mod.F90 new file mode 100644 index 000000000..fde4b8019 --- /dev/null +++ b/src/etrans/etrans/internal/einv_trans_ctl_mod.F90 @@ -0,0 +1,298 @@ +MODULE EINV_TRANS_CTL_MOD +CONTAINS +SUBROUTINE EINV_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& + & KF_UV,KF_SCALARS,KF_SCDERS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PSPMEANU,PSPMEANV) + +!**** *EINV_TRANS_CTL* - Control routine for inverse spectral transform. + +! Purpose. +! -------- +! Control routine for the inverse spectral transform + +!** Interface. +! ---------- +! CALL EINV_TRANS_CTL(...) + +! Explicit arguments : +! -------------------- +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! KF_OUT_LT - total number of fields coming out from inverse LT +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! KF_SCDERS - local number of derivatives of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition +! PGP(:,:,:) - gridpoint fields (output) + +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! vorticity : KF_UV_G fields +! divergence : KF_UV_G fields +! u : KF_UV_G fields +! v : KF_UV_G fields +! scalar fields : KF_SCALARS_G fields +! N-S derivative of scalar fields : KF_SCALARS_G fields +! E-W derivative of u : KF_UV_G fields +! E-W derivative of v : KF_UV_G fields +! E-W derivative of scalar fields : KF_SCALARS_G fields + +! Method. +! ------- + +! Externals. SHUFFLE - reshuffle fields for load balancing +! ---------- FIELD_SPLIT - split fields in NPROMATR packets +! LTINV_CTL - control of Legendre transform +! FTINV_CTL - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 01-01-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NPROMATR +USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP +!USE TPM_DISTR + +USE SHUFFLE_MOD ,ONLY : SHUFFLE +USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT +USE ELTINV_CTL_MOD ,ONLY : ELTINV_CTL +USE EFTINV_CTL_MOD ,ONLY : EFTINV_CTL +! + +IMPLICIT NONE + +! Declaration of arguments + +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP +INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) + +! Local variables + +INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) +INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) +INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) +INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G +INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP +INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT +INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Perform transform + +IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTL_MOD:EINV_TRANS_CTL',0,ZHOOK_HANDLE) +IF_GPB = 2*KF_UV_G+KF_SCALARS_G + +IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN + + ! Fields to be split into packets + + CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & + & KVSETUV,KVSETSC) + + IBLKS=(IF_GPB-1)/NPROMATR+1 + + DO JBLK=1,IBLKS + + CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& + & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& + & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) + + IF(LSCDERS) THEN + IF_SCDERS = IF_SCALARS + ELSE + IF_SCDERS = 0 + ENDIF + + IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS + IF(LVORGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV + ENDIF + IF(LDIVGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV + ENDIF + IF_FS = IF_OUT_LT+IF_SCDERS + IF(LUVDER) THEN + IF_FS = IF_FS+2*IF_UV + ENDIF + + IF_GP = 2*IF_UV_G+IF_SCALARS_G + IOFFD = 0 + IOFFU = 0 + IOFFV = KF_UV_G + IOFFUVD = 2*KF_UV_G+KF_SCALARS_G + IOFFSC = 2*KF_UV_G + IF(LVORGP) THEN + IF_GP = IF_GP+IF_UV_G + IOFFD = KF_UV_G + IOFFU = IOFFU+KF_UV_G + IOFFV = IOFFV+KF_UV_G + IOFFUVD =IOFFUVD+KF_UV_G + IOFFSC = IOFFSC+KF_UV_G + ENDIF + IF(LDIVGP) THEN + IF_GP = IF_GP+IF_UV_G + IOFFU = IOFFU+KF_UV_G + IOFFV = IOFFV+KF_UV_G + IOFFUVD =IOFFUVD+KF_UV_G + IOFFSC = IOFFSC+KF_UV_G + ENDIF + IF(LSCDERS) THEN + IF_GP = IF_GP+2*IF_SCALARS_G + IOFFUVD =IOFFUVD+KF_SCALARS_G + IOFFSCNS = IOFFSC+KF_SCALARS_G + IOFFSCEW = IOFFSC+2*KF_SCALARS_G + ENDIF + IF(LUVDER) THEN + IF_GP = IF_GP+2*IF_UV_G + IOFFSCEW = IOFFSCEW+2*KF_UV_G + ENDIF + + DO JFLD=1,IF_UV_G + IOFF = 0 + IF(LVORGP) THEN + IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + ENDIF + IF(LDIVGP) THEN + IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + ENDIF + IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G+IF_SCALARS_G + IF(LSCDERS) THEN + IOFF = IOFF+IF_SCALARS_G + ENDIF + IF(LUVDER) THEN + IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) + ENDIF + ENDDO + + DO JFLD=1,IF_SCALARS_G + IOFF = 2*IF_UV_G + IF (LVORGP) IOFF = IOFF+IF_UV_G + IF (LDIVGP) IOFF = IOFF+IF_UV_G + IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) + IOFF = IOFF+IF_SCALARS_G + IF(LSCDERS) THEN + IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) + IOFF = IOFF+IF_SCALARS_G + IF(LUVDER) THEN + IOFF = IOFF+2*IF_UV_G + ENDIF + IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) + ENDIF + ENDDO + DO JFLD=1,IF_UV + IPTRSPUV(JFLD) = ISTUV+JFLD-1 + ENDDO + DO JFLD=1,IF_SCALARS + IPTRSPSC(JFLD) = ISTSC+JFLD-1 + ENDDO + + CALL ELTINV_CTL(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& + & PSPMEANU=PSPMEANU,PSPMEANV=PSPMEANV,FSPGL_PROC=FSPGL_PROC) + + IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN + CALL EFTINV_CTL(IF_UV_G,IF_SCALARS_G,& + & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& + & PGP=PGP) + ELSEIF(IF_UV_G > 0) THEN + CALL EFTINV_CTL(IF_UV_G,IF_SCALARS_G,& + & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),KPTRGP=IPTRGP,& + & PGP=PGP) + ELSEIF(IF_SCALARS_G > 0) THEN + CALL EFTINV_CTL(IF_UV_G,IF_SCALARS_G,& + & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& + & PGP=PGP) + ENDIF + ENDDO + +ELSE + + ! No splitting of fields, transform done in one go + + CALL ELTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& + & PSPMEANU=PSPMEANU,PSPMEANV=PSPMEANV,FSPGL_PROC=FSPGL_PROC) + + CALL EFTINV_CTL(KF_UV_G,KF_SCALARS_G,& + & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& + & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& + & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& + & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) + +ENDIF +IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTL_MOD:EINV_TRANS_CTL',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EINV_TRANS_CTL +END MODULE EINV_TRANS_CTL_MOD diff --git a/src/etrans/etrans/internal/einv_trans_ctlad_mod.F90 b/src/etrans/etrans/internal/einv_trans_ctlad_mod.F90 new file mode 100644 index 000000000..aa00708c2 --- /dev/null +++ b/src/etrans/etrans/internal/einv_trans_ctlad_mod.F90 @@ -0,0 +1,292 @@ +MODULE EINV_TRANS_CTLAD_MOD +CONTAINS +SUBROUTINE EINV_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& + & KF_UV,KF_SCALARS,KF_SCDERS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& + & PMEANU,PMEANV) + +!**** *EINV_TRANS_CTLAD* - Control routine for inverse spectral transform adj. + +! Purpose. +! -------- +! Control routine for the inverse spectral transform + +!** Interface. +! ---------- +! CALL EINV_TRANS_CTLAD(...) + +! Explicit arguments : +! -------------------- +! KF_UV_G - global number of spectral u-v fields +! KF_SCALARS_G - global number of scalar spectral fields +! KF_GP - total number of output gridpoint fields +! KF_FS - total number of fields in fourier space +! KF_OUT_LT - total number of fields coming out from inverse LT +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! KF_SCDERS - local number of derivatives of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! KVSETUV(:) - indicating which 'b-set' in spectral space owns a +! vor/div field. Equivalant to NBSETLEV in the IFS. +! The length of KVSETUV should be the GLOBAL number +! of u/v fields which is the dimension of u and v releated +! fields in grid-point space. +! KVESETSC(:) - indicating which 'b-set' in spectral space owns a +! scalar field. As for KVSETUV this argument is required +! if the total number of processors is greater than +! the number of processors used for distribution in +! spectral wave space. +! PGP(:,:,:) - gridpoint fields (output) + +! The ordering of the output fields is as follows (all +! parts are optional depending on the input switches): + +! vorticity : KF_UV_G fields +! divergence : KF_UV_G fields +! u : KF_UV_G fields +! v : KF_UV_G fields +! scalar fields : KF_SCALARS_G fields +! N-S derivative of scalar fields : KF_SCALARS_G fields +! E-W derivative of u : KF_UV_G fields +! E-W derivative of v : KF_UV_G fields +! E-W derivative of scalar fields : KF_SCALARS_G fields + +! Method. +! ------- + +! Externals. SHUFFLE - reshuffle fields for load balancing +! ---------- FIELD_SPLIT - split fields in NPROMATR packets +! LTINV_CTLAD - control of Legendre transform +! FTINV_CTLAD - control of Fourier transform + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 01-01-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NPROMATR +USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP +!USE TPM_DISTR + +USE SHUFFLE_MOD ,ONLY : SHUFFLE +USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT +USE ELTINV_CTLAD_MOD ,ONLY : ELTINV_CTLAD +USE EFTINV_CTLAD_MOD ,ONLY : EFTINV_CTLAD +! + +IMPLICIT NONE + +! Declaration of arguments +! +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G +INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP +INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPUV(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3A(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3B(:,:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP2(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANV(:) + +! Local variables + +INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) +INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) +INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) +INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G +INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP +INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT +INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Perform transform + +IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTLAD_MOD:EINV_TRANS_CTLAD',0,ZHOOK_HANDLE) +IF_GPB = 2*KF_UV_G+KF_SCALARS_G +IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN + + ! Fields to be split into packets + + CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & + & KVSETUV,KVSETSC) + + IBLKS=(IF_GPB-1)/NPROMATR+1 + + DO JBLK=1,IBLKS + + CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& + & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& + & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) + + IF(LSCDERS) THEN + IF_SCDERS = IF_SCALARS + ELSE + IF_SCDERS = 0 + ENDIF + + IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS + IF(LVORGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV + ENDIF + IF(LDIVGP) THEN + IF_OUT_LT = IF_OUT_LT+IF_UV + ENDIF + IF_FS = IF_OUT_LT+IF_SCDERS + IF(LUVDER) THEN + IF_FS = IF_FS+2*IF_UV + ENDIF + + IF_GP = 2*IF_UV_G+IF_SCALARS_G + IOFFD = 0 + IOFFU = 0 + IOFFV = KF_UV_G + IOFFUVD = 2*KF_UV_G+KF_SCALARS_G + IOFFSC = 2*KF_UV_G + IF(LVORGP) THEN + IF_GP = IF_GP+IF_UV_G + IOFFD = KF_UV_G + IOFFU = IOFFU+KF_UV_G + IOFFV = IOFFV+KF_UV_G + IOFFUVD =IOFFUVD+KF_UV_G + IOFFSC = IOFFSC+KF_UV_G + ENDIF + IF(LDIVGP) THEN + IF_GP = IF_GP+IF_UV_G + IOFFU = IOFFU+KF_UV_G + IOFFV = IOFFV+KF_UV_G + IOFFUVD =IOFFUVD+KF_UV_G + IOFFSC = IOFFSC+KF_UV_G + ENDIF + IF(LSCDERS) THEN + IF_GP = IF_GP+2*IF_SCALARS_G + IOFFUVD =IOFFUVD+KF_SCALARS_G + IOFFSCNS = IOFFSC+KF_SCALARS_G + IOFFSCEW = IOFFSC+2*KF_SCALARS_G + ENDIF + IF(LUVDER) THEN + IF_GP = IF_GP+2*IF_UV_G + IOFFSCEW = IOFFSCEW+2*KF_UV_G + ENDIF + + DO JFLD=1,IF_UV_G + IOFF = 0 + IF(LVORGP) THEN + IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + ENDIF + IF(LDIVGP) THEN + IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + ENDIF + IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G+IF_SCALARS_G + IF(LSCDERS) THEN + IOFF = IOFF+IF_SCALARS_G + ENDIF + IF(LUVDER) THEN + IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) + IOFF = IOFF+IF_UV_G + IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) + ENDIF + ENDDO + + DO JFLD=1,IF_SCALARS_G + IOFF = 2*IF_UV_G + IF (LVORGP) IOFF = IOFF+IF_UV_G + IF (LDIVGP) IOFF = IOFF+IF_UV_G + IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) + IOFF = IOFF+IF_SCALARS_G + IF(LSCDERS) THEN + IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) + IOFF = IOFF+IF_SCALARS_G + IF(LUVDER) THEN + IOFF = IOFF+2*IF_UV_G + ENDIF + IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) + ENDIF + ENDDO + DO JFLD=1,IF_UV + IPTRSPUV(JFLD) = ISTUV+JFLD-1 + ENDDO + DO JFLD=1,IF_SCALARS + IPTRSPSC(JFLD) = ISTSC+JFLD-1 + ENDDO + + IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN + CALL EFTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& + & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& + & PGP=PGP) + ELSEIF(IF_UV_G > 0) THEN + CALL EFTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& + & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& + & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& + & KPTRGP=IPTRGP,& + & PGP=PGP) + ELSEIF(IF_SCALARS_G > 0) THEN + CALL EFTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& + & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& + & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& + & PGP=PGP) + ENDIF + CALL ELTINV_CTLAD(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& + & PSPMEANU=PMEANU,PSPMEANV=PMEANV) + ENDDO + +ELSE + + ! No splitting of fields, transform done in one go + + CALL EFTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& + & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& + & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& + & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& + & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) + + CALL ELTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & + & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& + & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& + & PSPMEANU=PMEANU,PSPMEANV=PMEANV ) +ENDIF +IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTLAD_MOD:EINV_TRANS_CTLAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EINV_TRANS_CTLAD +END MODULE EINV_TRANS_CTLAD_MOD diff --git a/src/etrans/etrans/internal/eledir_mod.F90 b/src/etrans/etrans/internal/eledir_mod.F90 new file mode 100644 index 000000000..12da60d98 --- /dev/null +++ b/src/etrans/etrans/internal/eledir_mod.F90 @@ -0,0 +1,99 @@ +MODULE ELEDIR_MOD +CONTAINS +SUBROUTINE ELEDIR(KM,KFC,KLED2,PFFT) + +!**** *ELEDIR* - Direct meridional transform. + +! Purpose. +! -------- +! Direct meridional tranform of state variables. + +!** Interface. +! ---------- +! CALL ELEDIR(...) + +! Explicit arguments : KM - zonal wavenumber +! -------------------- KFC - number of field to transform +! PAIA - antisymmetric part of Fourier +! fields for zonal wavenumber KM +! PSIA - symmetric part of Fourier +! fields for zonal wavenumber KM +! POA1 - spectral +! fields for zonal wavenumber KM +! PLEPO - Legendre polonomials + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. MXMAOP - matrix multiply +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 88-01-28 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified : 93-03-19 D. Giard - NTMAX instead of NSMAX +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 01-Sep-2015 support for FFTW transforms +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM, JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +USE TPM_DIM ,ONLY : R +!USE TPM_GEOMETRY +!USE TPM_TRANS +USE TPMALD_FFT ,ONLY : TALD +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW +#endif +USE TPMALD_DIM ,ONLY : RALD +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM,KFC,KLED2 +REAL(KIND=JPRB) , INTENT(INOUT) :: PFFT(:,:) + +INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE +! ------------------------------------------------------------------ + +!* 1. PERFORM FOURIER TRANFORM. +! -------------------------- + +IF (KFC>0) THEN + ITYPE=-1 + IRLEN=R%NDGL+R%NNOEXTZG + ICLEN=RALD%NDGLSUR+R%NNOEXTZG + IF( TALD%LFFT992 )THEN + CALL FFT992(PFFT,TALD%TRIGSE,TALD%NFAXE,1,ICLEN,IRLEN,KFC,ITYPE) +#ifdef WITH_FFTW + ELSEIF( TW%LFFTW )THEN + IOFF=1 + CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PFFT) +#endif + ELSE + CALL ABORT_TRANS('ELEDIR_MOD:ELEDIR: NO FFT PACKAGE SELECTED') + ENDIF +ENDIF + +! ------------------------------------------------------------------ + +END SUBROUTINE ELEDIR +END MODULE ELEDIR_MOD diff --git a/src/etrans/etrans/internal/eledirad_mod.F90 b/src/etrans/etrans/internal/eledirad_mod.F90 new file mode 100644 index 000000000..19dac6177 --- /dev/null +++ b/src/etrans/etrans/internal/eledirad_mod.F90 @@ -0,0 +1,118 @@ +MODULE ELEDIRAD_MOD +CONTAINS +SUBROUTINE ELEDIRAD(KM,KFC,KLED2,PFFT) + +!**** *ELEDIRAD* - Direct Legendre transform. + +! Purpose. +! -------- +! Direct Legendre tranform of state variables. + +!** Interface. +! ---------- +! CALL ELEDIRAD(...) + +! Explicit arguments : KM - zonal wavenumber +! -------------------- KFC - number of field to transform +! PAIA - antisymmetric part of Fourier +! fields for zonal wavenumber KM +! PSIA - symmetric part of Fourier +! fields for zonal wavenumber KM +! POA1 - spectral +! fields for zonal wavenumber KM +! PLEPO - Legendre polonomials + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. MXMAOP - matrix multiply +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 88-01-28 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified : 93-03-19 D. Giard - NTMAX instead of NSMAX +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib : fix missing support for FFTW +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +!USE TPM_GEOMETRY +!USE TPM_TRANS +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW +#endif +USE TPMALD_FFT ,ONLY : TALD +USE TPMALD_DIM ,ONLY : RALD +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KFC +INTEGER(KIND=JPIM), INTENT(IN) :: KLED2 + +REAL(KIND=JPRB), INTENT(INOUT) :: PFFT(:,:) + +INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE +INTEGER(KIND=JPIM) :: JF, JJ +REAL(KIND=JPRB) :: ZNORM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ELEDIRAD_MOD:ELEDIRAD',0,ZHOOK_HANDLE) + +IF (KFC>0) THEN + DO JJ=1,1 + DO JF=1,KFC + PFFT(JJ,JF) = 2.0_JPRB * PFFT(JJ,JF) + ENDDO + ENDDO + ITYPE=1 + IRLEN=R%NDGL+R%NNOEXTZG + ICLEN=RALD%NDGLSUR+R%NNOEXTZG + IF( TALD%LFFT992 )THEN + CALL FFT992(PFFT,TALD%TRIGSE,TALD%NFAXE,1,RALD%NDGLSUR+R%NNOEXTZG,IRLEN,KFC,ITYPE) +#ifdef WITH_FFTW + ELSEIF( TW%LFFTW )THEN + IOFF=1 + CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PFFT) +#endif + ELSE + CALL ABORT_TRANS('ELEDIR_MOD:ELEDIR: NO FFT PACKAGE SELECTED') + ENDIF + ZNORM=1.0_JPRB/(2.0_JPRB*REAL(R%NDGL+R%NNOEXTZG,JPRB)) + DO JJ=1,R%NDGL+R%NNOEXTZG + DO JF=1,KFC + PFFT(JJ,JF) = ZNORM * PFFT(JJ,JF) + ENDDO + ENDDO +ENDIF + +IF (LHOOK) CALL DR_HOOK('ELEDIRAD_MOD:ELEDIRAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELEDIRAD +END MODULE ELEDIRAD_MOD diff --git a/src/etrans/etrans/internal/eleinv_mod.F90 b/src/etrans/etrans/internal/eleinv_mod.F90 new file mode 100644 index 000000000..350ca74dc --- /dev/null +++ b/src/etrans/etrans/internal/eleinv_mod.F90 @@ -0,0 +1,103 @@ +MODULE ELEINV_MOD +CONTAINS +SUBROUTINE ELEINV(KM,KFC,KF_OUT_LT,PIA) + +!**** *LEINV* - Inverse Legendre transform. + +! Purpose. +! -------- +! Inverse Legendre tranform of all variables(kernel). + +!** Interface. +! ---------- +! CALL LEINV(...) + +! Explicit arguments : KM - zonal wavenumber (input-c) +! -------------------- KFC - number of fields to tranform (input-c) +! PIA - spectral fields +! for zonal wavenumber KM (input) +! PAOA1 - antisymmetric part of Fourier +! fields for zonal wavenumber KM (output) +! PSOA1 - symmetric part of Fourier +! fields for zonal wavenumber KM (output) +! PLEPO - Legendre polonomials for zonal +! wavenumber KM (input-c) + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. MXMAOP - calls SGEMVX (matrix multiply) +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From LEINV in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 01-Sep-2015 support for FFTW transforms +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM, JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +!USE TPM_GEOMETRY +!USE TPM_TRANS +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW +#endif +USE TPMALD_DIM ,ONLY : RALD +USE TPMALD_FFT ,ONLY : TALD +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KFC +INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT +REAL(KIND=JPRB), INTENT(INOUT) :: PIA(:,:) + +INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. PERFORM LEGENDRE TRANFORM. +! -------------------------- + +IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',0,ZHOOK_HANDLE) + +IF (KFC>0) THEN + ITYPE=1 + IRLEN=R%NDGL+R%NNOEXTZG + ICLEN=RALD%NDGLSUR+R%NNOEXTZG + IF( TALD%LFFT992 )THEN + CALL FFT992(PIA,TALD%TRIGSE,TALD%NFAXE,1,RALD%NDGLSUR+R%NNOEXTZG,IRLEN,KFC,ITYPE) +#ifdef WITH_FFTW + ELSEIF( TW%LFFTW )THEN + IOFF=1 + CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PIA) +#endif + ELSE + CALL ABORT_TRANS('ELEINV_MOD:ELEINV: NO FFT PACKAGE SELECTED') + ENDIF +ENDIF + +IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',1,ZHOOK_HANDLE) + +END SUBROUTINE ELEINV +END MODULE ELEINV_MOD diff --git a/src/etrans/etrans/internal/eleinvad_mod.F90 b/src/etrans/etrans/internal/eleinvad_mod.F90 new file mode 100644 index 000000000..15aa630cf --- /dev/null +++ b/src/etrans/etrans/internal/eleinvad_mod.F90 @@ -0,0 +1,115 @@ +MODULE ELEINVAD_MOD +CONTAINS +SUBROUTINE ELEINVAD(KM,KFC,KF_OUT_LT,PIA) + +!**** *ELEINVAD* - Inverse Legendre transform. + +! Purpose. +! -------- +! Inverse Legendre tranform of all variables(kernel). + +!** Interface. +! ---------- +! CALL ELEINVAD(...) + +! Explicit arguments : KM - zonal wavenumber (input-c) +! -------------------- KFC - number of fields to tranform (input-c) +! PIA - spectral fields +! for zonal wavenumber KM (input) +! PAOA1 - antisymmetric part of Fourier +! fields for zonal wavenumber KM (output) +! PSOA1 - symmetric part of Fourier +! fields for zonal wavenumber KM (output) +! PLEPO - Legendre polonomials for zonal +! wavenumber KM (input-c) + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. MXMAOP - calls SGEMVX (matrix multiply) +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From LEINVAD in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 01-Sep-2015 support for FFTW transforms +! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +!USE TPM_GEOMETRY +!USE TPM_TRANS +USE TPMALD_FFT ,ONLY : TALD +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW +#endif +USE TPMALD_DIM ,ONLY : RALD +USE TPMALD_FFT ,ONLY : TALD +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KFC +INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT +REAL(KIND=JPRB), INTENT(OUT) :: PIA(:,:) + +INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE +INTEGER(KIND=JPIM) :: JJ, JF +REAL(KIND=JPRB) :: ZNORM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ELEINVAD_MOD:ELEINVAD',0,ZHOOK_HANDLE) + +IF (KFC>0) THEN + ITYPE=-1 + IRLEN=R%NDGL+R%NNOEXTZG + ICLEN=RALD%NDGLSUR+R%NNOEXTZG + IF( TALD%LFFT992 )THEN + CALL FFT992(PIA,TALD%TRIGSE,TALD%NFAXE,1,ICLEN,IRLEN,KFC,ITYPE) +#ifdef WITH_FFTW + ELSEIF( TW%LFFTW )THEN + IOFF=1 + CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PIA) +#endif + ELSE + CALL ABORT_TRANS('ELEDIR_MOD:ELEINVAD: NO FFT PACKAGE SELECTED') + ENDIF + ZNORM=2.0_JPRB*REAL(R%NDGL+R%NNOEXTZG,JPRB) + DO JJ=1,1 + DO JF=1,KFC + PIA(JJ,JF) = (ZNORM/2.0_JPRB) * PIA(JJ,JF) + ENDDO + ENDDO + DO JJ=3,R%NDGL+R%NNOEXTZG+1 + DO JF=1,KFC + PIA(JJ,JF) = ZNORM * PIA(JJ,JF) + ENDDO + ENDDO +ENDIF + +IF (LHOOK) CALL DR_HOOK('ELEINVAD_MOD:ELEINVAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELEINVAD +END MODULE ELEINVAD_MOD diff --git a/src/etrans/etrans/internal/eltdir_ctl_mod.F90 b/src/etrans/etrans/internal/eltdir_ctl_mod.F90 new file mode 100644 index 000000000..5b38cb74e --- /dev/null +++ b/src/etrans/etrans/internal/eltdir_ctl_mod.F90 @@ -0,0 +1,117 @@ +MODULE ELTDIR_CTL_MOD +CONTAINS +SUBROUTINE ELTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & + & PSPVOR,PSPDIV,PSPSCALAR, & + & PSPSC3A,PSPSC3B,PSPSC2, & + & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV,AUX_PROC) + +!**** *ELTDIR_CTL* - Control routine for direct Legendre transform + +! Purpose. +! -------- +! Direct Legendre transform + +!** Interface. +! ---------- +! CALL ELTDIR_CTL(...) + +! Explicit arguments : +! -------------------- +! KF_FS - number of fields in Fourier space +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity (output) +! PSPDIV(:,:) - spectral divergence (output) +! PSPSCALAR(:,:) - spectral scalarvalued fields (output) +! KFLDPTRUV(:) - field pointer for vorticity and divergence (input) +! KFLDPTRSC(:) - field pointer for scalarvalued fields (input) +! PSPMEANU(:),PSPMEANV(:) - mean winds + +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : LALLOPERM +USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN +USE TPM_DISTR ,ONLY : D + +USE ELTDIR_MOD ,ONLY : ELTDIR +USE EUVTVD_COMM_MOD , ONLY : EUVTVD_COMM +USE TRLTOM_MOD ,ONLY : TRLTOM +USE MPL_MODULE + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANV(:) +EXTERNAL AUX_PROC +OPTIONAL AUX_PROC + +INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2,INUL +REAL(KIND=JPRB) :: ZDUM +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +! Transposition from Fourier space distribution to spectral space distribution + +IF (LHOOK) CALL DR_HOOK('ELTDIR_CTL_MOD:ELTDIR_CTL',0,ZHOOK_HANDLE) +IBLEN = D%NLENGT0B*2*KF_FS +IF (ALLOCATED(FOUBUF)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN + DEALLOCATE(FOUBUF) + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + ENDIF +ELSE + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + FOUBUF(1)=0._JPRB ! enforce allocation here +ENDIF +CALL GSTATS(153,0) +CALL TRLTOM(FOUBUF_IN,FOUBUF,2*KF_FS) +CALL GSTATS(153,1) +IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) + +! Periodization of auxiliary fields in y direction + +IF (PRESENT(AUX_PROC)) THEN + CALL AUX_PROC(ZDUM,FOUBUF,2*KF_FS,1,IBLEN,0,D%NUMP,.FALSE.,& + & INUL,D%NPROCL,D%NSTAGT0B,D%NPNTGTB1) +ENDIF + +! Direct Legendre transform + +ILED2 = 2*KF_FS +CALL GSTATS(1645,0) +IF (KF_FS>0) THEN +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) + DO JM=1,D%NUMP + IM = D%MYMS(JM) + CALL ELTDIR(IM,JM,KF_FS,KF_UV,KF_SCALARS,ILED2, & + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) + ENDDO +!$OMP END PARALLEL DO + IF (KF_UV > 0) THEN + CALL EUVTVD_COMM(KF_UV,PSPMEANU,PSPMEANV,KFLDPTRUV) + ENDIF +ENDIF +CALL GSTATS(1645,1) + +IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) +IF (LHOOK) CALL DR_HOOK('ELTDIR_CTL_MOD:ELTDIR_CTL',1,ZHOOK_HANDLE) + +! ----------------------------------------------------------------- + +END SUBROUTINE ELTDIR_CTL +END MODULE ELTDIR_CTL_MOD diff --git a/src/etrans/etrans/internal/eltdir_ctlad_mod.F90 b/src/etrans/etrans/internal/eltdir_ctlad_mod.F90 new file mode 100644 index 000000000..3433e8ca4 --- /dev/null +++ b/src/etrans/etrans/internal/eltdir_ctlad_mod.F90 @@ -0,0 +1,109 @@ +MODULE ELTDIR_CTLAD_MOD +CONTAINS +SUBROUTINE ELTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & + & PSPVOR,PSPDIV,PSPSCALAR, & + & PSPSC3A,PSPSC3B,PSPSC2, & + & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) + +!**** *ELTDIR_CTLAD* - Control routine for direct Legendre transform + +! Purpose. +! -------- +! Direct Legendre transform + +!** Interface. +! ---------- +! CALL LTDIR_CTLAD(...) + +! Explicit arguments : +! -------------------- +! PSPVOR(:,:) - spectral vorticity (output) +! PSPDIV(:,:) - spectral divergence (output) +! PSPSCALAR(:,:) - spectral scalarvalued fields (output) + +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : LALLOPERM +!USE TPM_DIM +USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN +USE TPM_DISTR ,ONLY : D + +USE ELTDIRAD_MOD ,ONLY : ELTDIRAD +USE TRMTOL_MOD ,ONLY : TRMTOL + + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANV(:) + +INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +! Transposition from Fourier space distribution to spectral space distribution + +IF (LHOOK) CALL DR_HOOK('ELTDIR_CTLAD_MOD:ELTDIR_CTLAD',0,ZHOOK_HANDLE) +IBLEN = D%NLENGT0B*2*KF_FS +IF (ALLOCATED(FOUBUF_IN)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN + DEALLOCATE(FOUBUF_IN) + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! force allocation here + ENDIF +ELSE + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! force allocation here +ENDIF +IF (ALLOCATED(FOUBUF)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN + DEALLOCATE(FOUBUF) + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + FOUBUF(1)=0._JPRB ! force allocation here + ENDIF +ELSE + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + FOUBUF(1)=0._JPRB ! force allocation here +ENDIF + +! Direct Legendre transform + +ILED2 = 2*KF_FS +CALL GSTATS(1646,0) +IF(KF_FS > 0) THEN +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) + DO JM=1,D%NUMP + IM = D%MYMS(JM) + CALL ELTDIRAD(IM,JM,KF_FS,KF_UV,KF_SCALARS,ILED2, & + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC, PSPMEANU,PSPMEANV) + ENDDO +!$OMP END PARALLEL DO +ENDIF +CALL GSTATS(1646,1) + +CALL GSTATS(181,0) +CALL TRMTOL(FOUBUF,FOUBUF_IN,2*KF_FS) +CALL GSTATS(181,1) +IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) +IF (LHOOK) CALL DR_HOOK('ELTDIR_CTLAD_MOD:ELTDIR_CTLAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELTDIR_CTLAD +END MODULE ELTDIR_CTLAD_MOD diff --git a/src/etrans/etrans/internal/eltdir_mod.F90 b/src/etrans/etrans/internal/eltdir_mod.F90 new file mode 100644 index 000000000..01a9a1ec8 --- /dev/null +++ b/src/etrans/etrans/internal/eltdir_mod.F90 @@ -0,0 +1,184 @@ +MODULE ELTDIR_MOD +CONTAINS +SUBROUTINE ELTDIR(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& + & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPM_DISTR ,ONLY : D +USE TPMALD_DIM ,ONLY : RALD + +USE EPRFI2_MOD ,ONLY : EPRFI2 +USE ELEDIR_MOD ,ONLY : ELEDIR +USE EUVTVD_MOD +USE EUPDSP_MOD ,ONLY : EUPDSP +USE EXTPER_MOD ,ONLY : EXTPER + +! +!**** *ELTDIR* - Control of Direct Legendre transform step + +! Purpose. +! -------- +! Tranform from Fourier space to spectral space, compute +! vorticity and divergence. + +!** Interface. +! ---------- +! *CALL* *ELTDIR(...)* + +! Explicit arguments : +! -------------------- KM - zonal wavenumber +! KMLOC - local zonal wavenumber + +! Implicit arguments : None +! -------------------- + +! Method. +! ------- + +! Externals. +! ---------- +! EPRFI2 - prepares the Fourier work arrays for model variables +! ELEDIR - direct Legendre transform +! EUVTVD - +! EUPDSP - updating of spectral arrays (fields) +! EUVTVD_COMM - +! EXTPER - + + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 87-11-24 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies +! Modified 93-11-18 M. Hamrud - use only one Fourier buffer +! Modified 94-04-06 R. El khatib Full-POS implementation +! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div +! instead of u,v->vor,div +! MPP Group : 95-10-01 Support for Distributed Memory version +! K. YESSAD (AUGUST 1996): +! - Legendre transforms for transmission coefficients. +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! 01-03-14 G. Radnoti aladin version +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KM +INTEGER(KIND=JPIM),INTENT(IN) :: KMLOC +INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANV(:) + +INTEGER(KIND=JPIM) :: IFC, IINDEX(2*KF_FS), JF, JDIM +INTEGER(KIND=JPIM) :: IFLD, IR, J +INTEGER(KIND=JPIM) :: IUS,IVS,IVORS,IDIVS + +REAL(KIND=JPRB) :: ZFFT(RALD%NDGLSUR+R%NNOEXTZG,KLED2,D%NUMP) +REAL(KIND=JPRB) :: ZVODI(RALD%NDGLSUR+R%NNOEXTZG,MAX(4*KF_UV,1),D%NUMP) + +! Only if R%NNOEXTZG > 0 : +REAL(KIND=JPRB) :: ZFFT2(KLED2,(RALD%NDGLSUR+R%NNOEXTZG)*MIN(1,R%NNOEXTZG)) + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ELTDIR_MOD:ELTDIR',0,ZHOOK_HANDLE) + +IUS = 1 +IVS = 2*KF_UV+1 +IVORS = IUS +IDIVS = IVS +IFC = 2*KF_FS + +!* 1. PREPARE WORK ARRAYS. +! -------------------- + +CALL EPRFI2(KM,KMLOC,KF_FS,ZFFT(:,:,KMLOC)) + +!* 2. PERIODICIZATION IN Y DIRECTION +! ------------------------------ + +IF(R%NNOEXTZG>0) THEN + DO JF = 1,IFC + DO JDIM = 1,R%NDGL + ZFFT2(JF,JDIM)=ZFFT(JDIM,JF,KMLOC) + ENDDO + ENDDO + IINDEX(1)=0 + CALL EXTPER(ZFFT2(:,:),R%NDGL+R%NNOEXTZG,1,R%NDGL,IFC,1,IINDEX,0) + DO JF = 1,IFC + DO JDIM = 1,R%NDGL+R%NNOEXTZG + ZFFT(JDIM,JF,KMLOC) = ZFFT2(JF,JDIM) + ENDDO + ENDDO +ENDIF + +!* 3. DIRECT LEGENDRE TRANSFORM. +! -------------------------- + +CALL ELEDIR(KM,IFC,KLED2,ZFFT(:,:,KMLOC)) + +!* 4. COMPUTE VORTICITY AND DIVERGENCE AND STORE MEAN WIND ON TASK OWNING WAVE 0 +! -------------------------------------------------------------------------- + +IF( KF_UV > 0 ) THEN + CALL EUVTVD(KM,KMLOC,KF_UV,ZFFT(:,IUS:,KMLOC),ZFFT(:,IVS:,KMLOC),& + & ZVODI(:,IVORS:,KMLOC),ZVODI(:,IDIVS:,KMLOC)) + IF (KM == 0) THEN + IF (PRESENT(KFLDPTRUV)) THEN + DO J = 1, KF_UV + IR = 2*J-1 + IFLD=KFLDPTRUV(J) + PSPMEANU(IFLD)=ZFFT(1,IUS-1+IR,KMLOC) + PSPMEANV(IFLD)=ZFFT(1,IVS-1+IR,KMLOC) + ENDDO + ELSE + DO J = 1, KF_UV + IR = 2*J-1 + PSPMEANU(J)=ZFFT(1,IUS-1+IR,KMLOC) + PSPMEANV(J)=ZFFT(1,IVS-1+IR,KMLOC) + ENDDO + ENDIF + ENDIF +ENDIF + +!* 5. UPDATE SPECTRAL ARRAYS. +! ----------------------- + +CALL EUPDSP(KM,KF_UV,KF_SCALARS,ZFFT(:,:,KMLOC),ZVODI(:,:,KMLOC), & + & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,KFLDPTRUV,KFLDPTRSC) + +IF (LHOOK) CALL DR_HOOK('ELTDIR_MOD:ELTDIR',1,ZHOOK_HANDLE) +! ------------------------------------------------------------------ + +END SUBROUTINE ELTDIR +END MODULE ELTDIR_MOD diff --git a/src/etrans/etrans/internal/eltdirad_mod.F90 b/src/etrans/etrans/internal/eltdirad_mod.F90 new file mode 100644 index 000000000..fd11df013 --- /dev/null +++ b/src/etrans/etrans/internal/eltdirad_mod.F90 @@ -0,0 +1,166 @@ +MODULE ELTDIRAD_MOD +CONTAINS +SUBROUTINE ELTDIRAD(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPMALD_DIM ,ONLY : RALD + +USE EPRFI2AD_MOD ,ONLY : EPRFI2AD +USE ELEDIRAD_MOD ,ONLY : ELEDIRAD +USE EUVTVDAD_MOD +USE EUPDSPAD_MOD ,ONLY : EUPDSPAD + + +!**** *ELTDIRAD* - Control of Direct Legendre transform step - adjoint + +! Purpose. +! -------- +! Tranform from Fourier space to spectral space, compute +! vorticity and divergence. + +!** Interface. +! ---------- +! *CALL* *ELTDIRAD(...)* + +! Explicit arguments : +! -------------------- KM - zonal wavenumber +! KMLOC - local zonal wavenumber +! PSPVOR - spectral vorticity +! PSPDIV - spectral divergence +! PSPSCALAR - spectral scalar variables + +! Implicit arguments : None +! -------------------- + +! Method. +! ------- + +! Externals. +! ---------- +! EPRFI2AD - prepares the Fourier work arrays for model variables. +! ELEDIRAD - direct Legendre transform +! EUVTVDAD - +! EUPDSPAD - updating of spectral arrays (fields) + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 87-11-24 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies +! Modified 93-11-18 M. Hamrud - use only one Fourier buffer +! Modified 94-04-06 R. El khatib Full-POS implementation +! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div +! instead of u,v->vor,div +! MPP Group : 95-10-01 Support for Distributed Memory version +! K. YESSAD (AUGUST 1996): +! - Legendre transforms for transmission coefficients. +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + +! thread-safety +! ------------------------------------------------------------------ +! +IMPLICIT NONE +! +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC +INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANV(:) + +INTEGER(KIND=JPIM) :: IFC +INTEGER(KIND=JPIM) :: IUS,IUE,IVS,IVE,IVORS,IVORE,IDIVS,IDIVE + +REAL(KIND=JPRB) :: ZFFT(RALD%NDGLSUR+R%NNOEXTZG,KLED2) +REAL(KIND=JPRB) :: ZVODI(RALD%NDGLSUR+R%NNOEXTZG,MAX(4*KF_UV,1)) +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM +! -------------------------------------- + +IF (LHOOK) CALL DR_HOOK('ELTDIRAD_MOD:ELTDIRAD',0,ZHOOK_HANDLE) +ZFFT=0.0_JPRB +ZVODI=0.0_JPRB + +! ------------------------------------------------------------------ + +!* 6. UPDATE SPECTRAL ARRAYS. +! ----------------------- + +CALL EUPDSPAD(KM,KF_UV,KF_SCALARS,ZFFT,ZVODI, & + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC) + +! ------------------------------------------------------------------ + +!* 5. COMPUTE VORTICITY AND DIVERGENCE. +! --------------------------------- +IF( KF_UV > 0 ) THEN + IUS = 1 + IUE = 2*KF_UV + IVS = 2*KF_UV+1 + IVE = 4*KF_UV + IVORS = 1 + IVORE = 2*KF_UV + IDIVS = 2*KF_UV+1 + IDIVE = 4*KF_UV +! SET PART OF ZFFT CONTAINING U AND V TO 0. + ZFFT(:,IUS:IVE) = 0.0_JPRB + CALL EUVTVDAD(KM,KMLOC,KF_UV,KFLDPTRUV,ZFFT(:,IUS:IUE),ZFFT(:,IVS:IVE),& + & ZVODI(:,IVORS:IVORE),ZVODI(:,IDIVS:IDIVE),PSPMEANU,PSPMEANV) +ENDIF + +! ------------------------------------------------------------------ + +!* 4. DIRECT LEGENDRE TRANSFORM. +! -------------------------- +IFC = 2*KF_FS +CALL ELEDIRAD(KM,IFC,KLED2,ZFFT) + +! ------------------------------------------------------------------ + +!* 3. FOURIER SPACE COMPUTATIONS. +! --------------------------- + +! ------------------------------------------------------------------ + +!* 2. PREPARE WORK ARRAYS. +! -------------------- + +CALL EPRFI2AD(KM,KMLOC,KF_FS,ZFFT) +IF (LHOOK) CALL DR_HOOK('ELTDIRAD_MOD:ELTDIRAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELTDIRAD +END MODULE ELTDIRAD_MOD + diff --git a/src/etrans/etrans/internal/eltinv_ctl_mod.F90 b/src/etrans/etrans/internal/eltinv_ctl_mod.F90 new file mode 100644 index 000000000..dea5b7b6e --- /dev/null +++ b/src/etrans/etrans/internal/eltinv_ctl_mod.F90 @@ -0,0 +1,129 @@ +MODULE ELTINV_CTL_MOD +CONTAINS +SUBROUTINE ELTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2,& + & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV,FSPGL_PROC) + +!**** *ELTINV_CTL* - Control routine for inverse Legandre transform. + +! Purpose. +! -------- +! Control routine for the inverse LEGENDRE transform + +!** Interface. +! ---------- +! CALL EINV_TRANS_CTL(...) +! KF_OUT_LT - number of fields coming out from inverse LT +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! KF_SCDERS - local number of derivatives of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! KFLDPTRUV(:) - field pointer array for vor./div. +! KFLDPTRSC(:) - field pointer array for PSPSCALAR +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition + +! Method. +! ------- + +! Externals. +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-06-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! O.Spaniel Oct-2004 phasing for AL29 +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : LALLOPERM +!USE TPM_DIM +USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN +USE TPM_DISTR ,ONLY : D + +USE ELTINV_MOD ,ONLY : ELTINV +USE TRMTOL_MOD ,ONLY : TRMTOL +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) + +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC + +INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILEI2,IDIM1 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ELTINV_CTL_MOD:ELTINV_CTL',0,ZHOOK_HANDLE) +ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS +IDIM1 = 2*KF_OUT_LT +IBLEN = D%NLENGT0B*2*KF_OUT_LT +IF (ALLOCATED(FOUBUF)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN + DEALLOCATE(FOUBUF) + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + FOUBUF(1)=0._JPRB ! to force allocation here + ENDIF +ELSE + ALLOCATE(FOUBUF(MAX(1,IBLEN))) + FOUBUF(1)=0._JPRB ! to force allocation here +ENDIF +IF (ALLOCATED(FOUBUF_IN)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN + DEALLOCATE(FOUBUF_IN) + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! to force allocation here + ENDIF +ELSE + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! to force allocation here +ENDIF + +IF(KF_OUT_LT > 0) THEN +CALL GSTATS(1647,0) +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) + DO JM=1,D%NUMP + IM = D%MYMS(JM) + CALL ELTINV(IM,JM,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,& + & PSPVOR,PSPDIV,PSPSCALAR ,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) + ENDDO +!$OMP END PARALLEL DO +CALL GSTATS(1647,1) +ENDIF + +CALL GSTATS(152,0) +CALL TRMTOL(FOUBUF_IN,FOUBUF,2*KF_OUT_LT) +CALL GSTATS(152,1) +IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) +IF (LHOOK) CALL DR_HOOK('ELTINV_CTL_MOD:ELTINV_CTL',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELTINV_CTL +END MODULE ELTINV_CTL_MOD diff --git a/src/etrans/etrans/internal/eltinv_ctlad_mod.F90 b/src/etrans/etrans/internal/eltinv_ctlad_mod.F90 new file mode 100644 index 000000000..43e8f4c4c --- /dev/null +++ b/src/etrans/etrans/internal/eltinv_ctlad_mod.F90 @@ -0,0 +1,116 @@ +MODULE ELTINV_CTLAD_MOD +CONTAINS +SUBROUTINE ELTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2,& + & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) + +!**** *ELTINV_CTLAD* - Control routine for inverse Legandre transform - adj. + +! Purpose. +! -------- +! Control routine for the inverse LEGENDRE transform + +!** Interface. +! ---------- +! CALL EINV_TRANS_CTL(...) +! KF_OUT_LT - number of fields coming out from inverse LT +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! KF_SCDERS - local number of derivatives of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! KFLDPTRUV(:) - field pointer array for vor./div. +! KFLDPTRSC(:) - field pointer array for PSPSCALAR +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition + +! Method. +! ------- + +! Externals. +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-06-03 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! O.Spaniel Oct-2004 phasing for AL29 +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + +! thread-safety +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE TPM_GEN ,ONLY : LALLOPERM +!USE TPM_DIM +USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN +USE TPM_DISTR ,ONLY : D +USE ELTINVAD_MOD ,ONLY : ELTINVAD +USE TRLTOM_MOD ,ONLY : TRLTOM +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT +INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS +INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCDERS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANV(:) + +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC + +INTEGER(KIND=JPIM) :: IBLEN, ILEI2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ELTINV_CTLAD_MOD:ELTINV_CTLAD',0,ZHOOK_HANDLE) + +ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS +IBLEN = D%NLENGT0B*2*KF_OUT_LT +IF (ALLOCATED(FOUBUF_IN)) THEN + IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN + DEALLOCATE(FOUBUF_IN) + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! force allocation here + ENDIF +ELSE + ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) + FOUBUF_IN(1)=0._JPRB ! force allocation here +ENDIF +CALL GSTATS(180,0) +CALL TRLTOM(FOUBUF,FOUBUF_IN,2*KF_OUT_LT) +CALL GSTATS(180,1) +IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) + +CALL GSTATS(1648,0) +IF(KF_OUT_LT > 0) THEN + CALL ELTINVAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,& + & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & + & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) +ENDIF +CALL GSTATS(1648,1) + +IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) +IF (LHOOK) CALL DR_HOOK('ELTINV_CTLAD_MOD:ELTINV_CTLAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELTINV_CTLAD +END MODULE ELTINV_CTLAD_MOD diff --git a/src/etrans/etrans/internal/eltinv_mod.F90 b/src/etrans/etrans/internal/eltinv_mod.F90 new file mode 100644 index 000000000..524ace889 --- /dev/null +++ b/src/etrans/etrans/internal/eltinv_mod.F90 @@ -0,0 +1,213 @@ +MODULE ELTINV_MOD +CONTAINS +SUBROUTINE ELTINV(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B +USE TPMALD_DIM ,ONLY : RALD +USE EPRFI1B_MOD ,ONLY : EPRFI1B +USE EVDTUV_MOD ,ONLY : EVDTUV +USE ESPNSDE_MOD ,ONLY : ESPNSDE +USE ELEINV_MOD ,ONLY : ELEINV +USE EASRE1B_MOD ,ONLY : EASRE1B +USE FSPGL_INT_MOD ,ONLY : FSPGL_INT +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +!**** *LTINV* - Inverse Legendre transform + +! Purpose. +! -------- +! Tranform from Laplace space to Fourier space, compute U and V +! and north/south derivatives of state variables. + +!** Interface. +! ---------- +! *CALL* *LTINV(...) + +! Explicit arguments : +! -------------------- +! KM - zonal wavenumber +! KMLOC - local zonal wavenumber +! PSPVOR - spectral vorticity +! PSPDIV - spectral divergence +! PSPSCALAR - spectral scalar variables + +! Implicit arguments : The Laplace arrays of the model. +! -------------------- The values of the Legendre polynomials +! The grid point arrays of the model +! Method. +! ------- + +! Externals. +! ---------- + +! PREPSNM - prepare REPSNM for wavenumber KM +! PRFI1B - prepares the spectral fields +! VDTUV - compute u and v from vorticity and divergence +! SPNSDE - compute north-south derivatives +! LEINV - Inverse Legendre transform +! ASRE1 - recombination of symmetric/antisymmetric part + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS +! Temperton, 1991, MWR 119 p1303 + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From LTINV in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! R. El Khatib 26-Aug-2021 Optimization for EASRE1B +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC +INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS +INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 +INTEGER(KIND=JPIM), INTENT(IN) :: KDIM1 + +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC + +REAL(KIND=JPRB) :: ZIA(RALD%NDGLSUR+R%NNOEXTZG,KLEI2) + +INTEGER(KIND=JPIM) :: IFC, ISTA +INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU +INTEGER(KIND=JPIM) :: IFIRST, ILAST,IDIM1,IDIM3,J3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + + +! ------------------------------------------------------------------ + +!* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. +! ---------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('ELTINV_MOD:ELTINV',0,ZHOOK_HANDLE) +IFIRST = 1 +ILAST = 4*KF_UV +ZIA=0.0_JPRB +IF (KF_UV > 0) THEN + IVORL = 1 + IVORU = 2*KF_UV + IDIVL = 2*KF_UV+1 + IDIVU = 4*KF_UV + IUL = 4*KF_UV+1 + IUU = 6*KF_UV + IVL = 6*KF_UV+1 + IVU = 8*KF_UV + CALL EPRFI1B(KM,ZIA(:,IVORL:IVORU),PSPVOR,KF_UV,KFLDPTRUV) + CALL EPRFI1B(KM,ZIA(:,IDIVL:IDIVU),PSPDIV,KF_UV,KFLDPTRUV) + ILAST = ILAST+4*KF_UV + CALL EVDTUV(KM,KF_UV,KFLDPTRUV,ZIA(:,IVORL:IVORU),ZIA(:,IDIVL:IDIVU),& + & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU),PSPMEANU,PSPMEANV) + +ENDIF + +IF(KF_SCALARS > 0)THEN + IF(PRESENT(PSPSCALAR)) THEN + IFIRST = ILAST+1 + ILAST = IFIRST - 1 + 2*KF_SCALARS + CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) + ELSE + IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN + IFIRST = ILAST+1 + ILAST = IFIRST-1+2*NF_SC2 + CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC2(:,:),NF_SC2) + ENDIF + IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN + IDIM1=NF_SC3A + IDIM3=UBOUND(PSPSC3A,3) + DO J3=1,IDIM3 + IFIRST = ILAST+1 + ILAST = IFIRST-1+2*IDIM1 + CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC3A(:,:,J3),IDIM1) + ENDDO + ENDIF + IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN + IDIM1=NF_SC3B + IDIM3=UBOUND(PSPSC3B,3) + DO J3=1,IDIM3 + IFIRST = ILAST+1 + ILAST = IFIRST-1+2*IDIM1 + CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC3B(:,:,J3),IDIM1) + ENDDO + ENDIF + ENDIF + IF(ILAST /= 8*KF_UV+2*KF_SCALARS) THEN + WRITE(0,*) 'LTINV:KF_UV,KF_SCALARS,ILAST ',KF_UV,KF_SCALARS,ILAST + CALL ABORT_TRANS('LTINV_MOD:ILAST /= 8*KF_UV+2*KF_SCALARS') + ENDIF +ENDIF + +IF (KF_SCDERS > 0) THEN + ISL = 2*(4*KF_UV)+1 + ISU = ISL+2*KF_SCALARS-1 + IDL = 2*(4*KF_UV+KF_SCALARS)+1 + IDU = IDL+2*KF_SCDERS-1 + CALL ESPNSDE(KM,KF_SCALARS,ZIA(:,ISL:ISU),ZIA(:,IDL:IDU)) +ENDIF + +! ------------------------------------------------------------------ + +!* 4. INVERSE LEGENDRE TRANSFORM. +! --------------------------- + +ISTA = 1 +IFC = 2*KF_OUT_LT +IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN + ISTA = ISTA+2*KF_UV +ENDIF +IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN + ISTA = ISTA+2*KF_UV +ENDIF + +CALL ELEINV(KM,IFC,KF_OUT_LT,ZIA(:,ISTA:ISTA+IFC-1)) + +! ------------------------------------------------------------------ + +!* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. +! -------------------------------------------- + +CALL EASRE1B(IFC,KM,KMLOC,ZIA(:,ISTA:ISTA+IFC-1)) +! ------------------------------------------------------------------ + +! 6. OPTIONAL COMPUTATIONS IN FOURIER SPACE + +IF(PRESENT(FSPGL_PROC)) THEN + CALL FSPGL_INT(KM,KMLOC,KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT,FSPGL_PROC,& + & KFLDPTRUV,KFLDPTRSC) +ENDIF +IF (LHOOK) CALL DR_HOOK('ELTINV_MOD:ELTINV',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELTINV +END MODULE ELTINV_MOD + diff --git a/src/etrans/etrans/internal/eltinvad_mod.F90 b/src/etrans/etrans/internal/eltinvad_mod.F90 new file mode 100644 index 000000000..a332b2eb3 --- /dev/null +++ b/src/etrans/etrans/internal/eltinvad_mod.F90 @@ -0,0 +1,252 @@ +MODULE ELTINVAD_MOD +CONTAINS +SUBROUTINE ELTINVAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,& + & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& + & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) + +!**** *ELTINVAD* - Control routine for inverse Legandre transform - adj. + +! Purpose. +! -------- +! Control routine for the inverse LEGENDRE transform + +!** Interface. +! ---------- +! CALL ELTINVAD(...) +! KF_OUT_LT - number of fields coming out from inverse LT +! KF_UV - local number of spectral u-v fields +! KF_SCALARS - local number of scalar spectral fields +! KF_SCDERS - local number of derivatives of scalar spectral fields +! PSPVOR(:,:) - spectral vorticity (input) +! PSPDIV(:,:) - spectral divergence (input) +! PSPSCALAR(:,:) - spectral scalarvalued fields (input) +! KFLDPTRUV(:) - field pointer array for vor./div. +! KFLDPTRSC(:) - field pointer array for PSPSCALAR +! FSPGL_PROC - external procedure to be executed in fourier space +! before transposition + +! Method. +! ------- + +! Externals. +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From LTINVAD in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! 01-Dec-2004 A. Deckmyn add KMLOC to EVDTUVAD call +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + +! thread-safety +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN +USE TPM_DIM ,ONLY : R +USE TPMALD_DIM ,ONLY : RALD +USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B +USE TPM_DISTR + +USE EASRE1BAD_MOD ,ONLY : EASRE1BAD +USE ELEINVAD_MOD ,ONLY : ELEINVAD +USE EPRFI1BAD_MOD ,ONLY : EPRFI1BAD +USE ESPNSDEAD_MOD ,ONLY : ESPNSDEAD +USE EVDTUVAD_MOD ,ONLY : EVDTUVAD +USE EVDTUVAD_COMM_MOD +USE EXTPER_MOD ,ONLY : EXTPER + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS +INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANU(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANV(:) + +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) + +EXTERNAL FSPGL_PROC +OPTIONAL FSPGL_PROC + +REAL(KIND=JPRB) :: ZIA(RALD%NDGLSUR+R%NNOEXTZG,KLEI2,D%NUMP) +REAL(KIND=JPRB) :: ZIA2(KLEI2,RALD%NDGLSUR+R%NNOEXTZG) + +INTEGER(KIND=JPIM) :: IFC, ISTA, IINDEX(2*KF_OUT_LT), JF, JDIM, IM, JM +INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU +INTEGER(KIND=JPIM) :: ILAST,IFIRST,IDIM1,IDIM3,J3 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ELTINVAD_MOD:ELTINVAD',0,ZHOOK_HANDLE) + +IF (KF_UV > 0) THEN + IVORL = 1 + IVORU = 2*KF_UV + IDIVL = 2*KF_UV+1 + IDIVU = 4*KF_UV + IUL = 4*KF_UV+1 + IUU = 6*KF_UV + IVL = 6*KF_UV+1 + IVU = 8*KF_UV +ENDIF +ISTA = 1 +IFC = 2*KF_OUT_LT +IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN + ISTA = ISTA+2*KF_UV +ENDIF +IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN + ISTA = ISTA+2*KF_UV +ENDIF +IF (KF_SCDERS > 0) THEN + ISL = 2*(4*KF_UV)+1 + ISU = ISL+2*KF_SCALARS-1 + IDL = 2*(4*KF_UV+KF_SCALARS)+1 + IDU = IDL+2*KF_SCDERS-1 +ENDIF + +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM,JF,JDIM,IINDEX,ZIA2) +DO JM=1,D%NUMP + IM = D%MYMS(JM) + +! 7. OPTIONAL COMPUTATIONS IN FOURIER SPACE +! -------------------------------------- + +!commented IF(PRESENT(FSPGL_PROC)) THEN +!commented CALL FSPGL_INT(IM,JM,FSPGL_PROC) +!commented ENDIF + + +!* 6. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. +! -------------------------------------------- + + ZIA(:,:,JM)=0.0_JPRB + CALL EASRE1BAD(IFC,IM,JM,ZIA(:,ISTA:ISTA+IFC-1,JM)) + + +!* 5. PERIODICIZATION IN Y DIRECTION +! ------------------------------ + + IF(R%NNOEXTZG>0) THEN + DO JF = 1,IFC + DO JDIM = 1,R%NDGL + ZIA2(JF,JDIM)=ZIA(JDIM,JF,JM) + ENDDO + ENDDO + IINDEX(1)=0 + CALL EXTPER(ZIA2(:,:),R%NDGL+R%NNOEXTZG,1,R%NDGL,IFC,1,IINDEX,0) + DO JF = 1,IFC + DO JDIM = 1,R%NDGL+R%NNOEXTZG + ZIA(JDIM,JF,JM) = ZIA2(JF,JDIM) + ENDDO + ENDDO + ENDIF + +!* 4. INVERSE LEGENDRE TRANSFORM. +! --------------------------- + + CALL ELEINVAD(IM,IFC,KF_OUT_LT,ZIA(:,ISTA:ISTA+IFC-1,JM)) + + +!* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. +! ---------------------------------------------- + + ZIA(:,1:ISTA-1,JM) = 0.0_JPRB + + IF (KF_UV > 0) THEN + CALL EVDTUVAD(IM,JM,KF_UV,KFLDPTRUV,ZIA(:,IVORL:IVORU,JM),ZIA(:,IDIVL:IDIVU,JM),& + & ZIA(:,IUL:IUU,JM),ZIA(:,IVL:IVU,JM),PSPMEANU,PSPMEANV) + ENDIF + + +ENDDO +!$OMP END PARALLEL DO + +!* 2. COMMUNICATION OF MEAN WIND +! -------------------------- + +IF (KF_UV > 0) THEN + DO JM=1,D%NUMP + IM = D%MYMS(JM) + CALL EVDTUVAD_COMM(IM,JM,KF_UV,KFLDPTRUV,PSPMEANU,PSPMEANV) + ENDDO +ENDIF + +!* 2. PREPARE SPECTRAL FIELDS +! ----------------------- + +!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM,IFIRST,ILAST,IDIM1,IDIM3) +DO JM=1,D%NUMP + IM = D%MYMS(JM) + + IFIRST = 1 + ILAST = 4*KF_UV + IF (KF_UV > 0) THEN + CALL EPRFI1BAD(IM,ZIA(:,IVORL:IVORU,JM),PSPVOR,KF_UV,KFLDPTRUV) + CALL EPRFI1BAD(IM,ZIA(:,IDIVL:IDIVU,JM),PSPDIV,KF_UV,KFLDPTRUV) + ILAST = ILAST+4*KF_UV + ENDIF + + IF (KF_SCDERS > 0) THEN + CALL ESPNSDEAD(IM,KF_SCALARS,ZIA(:,ISL:ISU,JM),ZIA(:,IDL:IDU,JM)) + ENDIF + + IF(KF_SCALARS > 0)THEN + IF(PRESENT(PSPSCALAR)) THEN + IFIRST = ILAST+1 + ILAST = IFIRST - 1 + 2*KF_SCALARS + CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) + ELSE + IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN + IFIRST = ILAST+1 + ILAST = IFIRST-1+2*NF_SC2 + CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSC2(:,:),NF_SC2) + ENDIF + IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN + IDIM1=NF_SC3A + IDIM3=UBOUND(PSPSC3A,3) + DO J3=1,IDIM3 + IFIRST = ILAST+1 + ILAST = IFIRST-1+2*IDIM1 + CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSC3A(:,:,J3),IDIM1) + ENDDO + ENDIF + IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN + IDIM1=NF_SC3B + IDIM3=UBOUND(PSPSC3B,3) + DO J3=1,IDIM3 + IFIRST = ILAST+1 + ILAST = IFIRST-1+2*IDIM1 + CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSC3B(:,:,J3),IDIM1) + ENDDO + ENDIF + ENDIF + ENDIF + +ENDDO +!$OMP END PARALLEL DO + +IF (LHOOK) CALL DR_HOOK('ELTINVAD_MOD:ELTINVAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ELTINVAD +END MODULE ELTINVAD_MOD diff --git a/src/etrans/etrans/internal/eprfi1_mod.F90 b/src/etrans/etrans/internal/eprfi1_mod.F90 new file mode 100644 index 000000000..3e3feca51 --- /dev/null +++ b/src/etrans/etrans/internal/eprfi1_mod.F90 @@ -0,0 +1,105 @@ +MODULE EPRFI1_MOD +CONTAINS +SUBROUTINE EPRFI1(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& + & KFLDPTRUV,KFLDPTRSC) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DISTR +!USE TPM_TRANS + +USE EPRFI1B_MOD ,ONLY : EPRFI1B + +!**** *PRFI1* - Prepare spectral fields for inverse Legendre transform + +! Purpose. +! -------- +! To extract the spectral fields for a specific zonal wavenumber +! and put them in an order suitable for the inverse Legendre . +! tranforms.The ordering is from NSMAX to KM for better conditioning. +! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing +! u,v and derivatives in spectral space. + +!** Interface. +! ---------- +! *CALL* *EPRFI1(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR + +! Explicit arguments : KM - zonal wavenumber +! ------------------ PIA - spectral components for transform +! PSPVOR - vorticity +! PSPDIV - divergence +! PSPSCALAR - scalar variables + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From PRFI1 in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KM +INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV +INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) , INTENT(OUT) :: PIA(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) + +INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. +! ------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EPRFI1_MOD:EPRFI1',0,ZHOOK_HANDLE) +IFIRST = 1 +ILAST = 4*KF_UV + +!* 1.1 VORTICITY AND DIVERGENCE. + +IF(KF_UV > 0)THEN + IVOR = 1 + IDIV = 2*KF_UV+1 + CALL EPRFI1B(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) + CALL EPRFI1B(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) + ILAST = ILAST+4*KF_UV +ENDIF + +!* 1.2 SCALAR VARIABLES. + +IF(KF_SCALARS > 0)THEN + IFIRST = ILAST+1 + ILAST = IFIRST - 1 + 2*KF_SCALARS + CALL EPRFI1B(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) +ENDIF +IF (LHOOK) CALL DR_HOOK('EPRFI1_MOD:EPRFI1',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI1 +END MODULE EPRFI1_MOD + diff --git a/src/etrans/etrans/internal/eprfi1ad_mod.F90 b/src/etrans/etrans/internal/eprfi1ad_mod.F90 new file mode 100644 index 000000000..ad7cd1725 --- /dev/null +++ b/src/etrans/etrans/internal/eprfi1ad_mod.F90 @@ -0,0 +1,103 @@ +MODULE EPRFI1AD_MOD +CONTAINS +SUBROUTINE EPRFI1AD(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& + & KFLDPTRUV,KFLDPTRSC) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DISTR +!USE TPM_TRANS + +USE EPRFI1BAD_MOD ,ONLY : EPRFI1BAD + +!**** *EPRFI1AD* - Prepare spectral fields for inverse Legendre transform + +! Purpose. +! -------- +! To extract the spectral fields for a specific zonal wavenumber +! and put them in an order suitable for the inverse Legendre . +! tranforms.The ordering is from NSMAX to KM for better conditioning. +! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing +! u,v and derivatives in spectral space. + +!** Interface. +! ---------- +! *CALL* *EPRFI1AD(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR + +! Explicit arguments : KM - zonal wavenumber +! ------------------ PIA - spectral components for transform +! PSPVOR - vorticity +! PSPDIV - divergence +! PSPSCALAR - scalar variables + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From PRFI1AD in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ +! +IMPLICIT NONE +! +! +INTEGER(KIND=JPIM),INTENT(IN) :: KM,KF_UV,KF_SCALARS +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) , INTENT(IN) :: PIA(:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) + +INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. +! ------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EPRFI1AD_MOD:EPRFI1AD',0,ZHOOK_HANDLE) +IFIRST = 1 +ILAST = 4*KF_UV + +!* 1.1 VORTICITY AND DIVERGENCE. + +IF(KF_UV > 0)THEN + IVOR = 1 + IDIV = 2*KF_UV+1 + CALL EPRFI1BAD(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) + CALL EPRFI1BAD(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) + ILAST = ILAST+4*KF_UV +ENDIF + +!* 1.2 SCALAR VARIABLES. + +IF(KF_SCALARS > 0)THEN + IFIRST = ILAST+1 + ILAST = IFIRST - 1 + 2*KF_SCALARS + CALL EPRFI1BAD(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) +ENDIF +IF (LHOOK) CALL DR_HOOK('EPRFI1AD_MOD:EPRFI1AD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI1AD +END MODULE EPRFI1AD_MOD diff --git a/src/etrans/etrans/internal/eprfi1b_mod.F90 b/src/etrans/etrans/internal/eprfi1b_mod.F90 new file mode 100644 index 000000000..1a64daf29 --- /dev/null +++ b/src/etrans/etrans/internal/eprfi1b_mod.F90 @@ -0,0 +1,110 @@ +MODULE EPRFI1B_MOD +CONTAINS +SUBROUTINE EPRFI1B(KM,PIA,PSPEC,KFIELDS,KFLDPTR) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DIM +!USE TPM_DISTR +USE TPMALD_DISTR ,ONLY : DALD +! +!**** *PRFI1* - Prepare spectral fields for inverse Legendre transform + +! Purpose. +! -------- +! To extract the spectral fields for a specific zonal wavenumber +! and put them in an order suitable for the inverse Legendre . +! tranforms.The ordering is from NSMAX to KM for better conditioning. +! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing +! u,v and derivatives in spectral space. + +!** Interface. +! ---------- +! *CALL* *PRFI1B(...)* + +! Explicit arguments : KM - zonal wavenumber +! ------------------ PIA - spectral components for transform +! PSPEC - spectral array +! KFIELDS - number of fields + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From PRFI1B in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELDS +REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) +REAL(KIND=JPRB) ,INTENT(OUT) :: PIA(:,:) +INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) + +INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF,IFLD +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. +! -------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('EPRFI1B_MOD:EPRFI1B',0,ZHOOK_HANDLE) +ILCM = DALD%NCPL2M(KM) +IOFF = DALD%NESM0(KM) + +IF(PRESENT(KFLDPTR)) THEN + DO JFLD=1,KFIELDS + IR = 2*(JFLD-1)+1 + II = IR+1 + IFLD = KFLDPTR(JFLD) + DO J=1,ILCM,2 + INM = IOFF+(J-1)*2 + PIA(J ,IR) = PSPEC(IFLD,INM ) + PIA(J+1,IR) = PSPEC(IFLD,INM+1) + PIA(J ,II) = PSPEC(IFLD,INM+2) + PIA(J+1,II) = PSPEC(IFLD,INM+3) + ENDDO + ENDDO + +ELSE + DO J=1,ILCM,2 + INM = IOFF+(J-1)*2 + !DIR$ IVDEP + !OCL NOVREC + !cdir unroll=4 + DO JFLD=1,KFIELDS + IR = 2*(JFLD-1)+1 + II = IR+1 + PIA(J ,IR) = PSPEC(JFLD,INM ) + PIA(J+1,IR) = PSPEC(JFLD,INM+1) + PIA(J ,II) = PSPEC(JFLD,INM+2) + PIA(J+1,II) = PSPEC(JFLD,INM+3) + ENDDO + ENDDO + +ENDIF +IF (LHOOK) CALL DR_HOOK('EPRFI1B_MOD:EPRFI1B',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI1B +END MODULE EPRFI1B_MOD diff --git a/src/etrans/etrans/internal/eprfi1bad_mod.F90 b/src/etrans/etrans/internal/eprfi1bad_mod.F90 new file mode 100644 index 000000000..81a31ea69 --- /dev/null +++ b/src/etrans/etrans/internal/eprfi1bad_mod.F90 @@ -0,0 +1,110 @@ +MODULE EPRFI1BAD_MOD +CONTAINS +SUBROUTINE EPRFI1BAD(KM,PIA,PSPEC,KFIELDS,KFLDPTR) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPMALD_DISTR ,ONLY : DALD + +!**** *EPRFI1BAD* - Prepare spectral fields for inverse Legendre transform + +! Purpose. +! -------- +! To extract the spectral fields for a specific zonal wavenumber +! and put them in an order suitable for the inverse Legendre . +! tranforms.The ordering is from NSMAX to KM for better conditioning. +! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing +! u,v and derivatives in spectral space. + +!** Interface. +! ---------- +! *CALL* *EPRFI1BAD(...)* + +! Explicit arguments : KM - zonal wavenumber +! ------------------ PIA - spectral components for transform +! PSPEC - spectral array +! KFIELDS - number of fields + +! Implicit arguments : None. +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From PRFI1BAD in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELDS +REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) +REAL(KIND=JPRB) ,INTENT(IN) :: PIA(:,:) +INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) + +INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF, IFLD +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. +! -------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('EPRFI1BAD_MOD:EPRFI1BAD',0,ZHOOK_HANDLE) +ILCM=DALD%NCPL2M(KM) + +IOFF = DALD%NESM0(KM) + +IF(PRESENT(KFLDPTR)) THEN + DO JFLD=1,KFIELDS + IR = 2*(JFLD-1)+1 + II = IR+1 + IFLD = KFLDPTR(JFLD) + DO J=1,ILCM,2 + INM = IOFF+(J-1)*2 + + PSPEC(IFLD,INM ) = PSPEC(IFLD,INM ) + PIA(J ,IR) + PSPEC(IFLD,INM+1) = PSPEC(IFLD,INM+1) + PIA(J+1,IR) + PSPEC(IFLD,INM+2) = PSPEC(IFLD,INM+2) + PIA(J ,II) + PSPEC(IFLD,INM+3) = PSPEC(IFLD,INM+3) + PIA(J+1,II) + + ENDDO + ENDDO +ELSE + DO J=1,ILCM,2 + INM = IOFF+(J-1)*2 +!DIR$ IVDEP +!OCL NOVREC + DO JFLD=1,KFIELDS + IR = 2*(JFLD-1)+1 + II = IR+1 + + PSPEC(JFLD,INM ) = PSPEC(JFLD,INM ) + PIA(J ,IR) + PSPEC(JFLD,INM+1) = PSPEC(JFLD,INM+1) + PIA(J+1,IR) + PSPEC(JFLD,INM+2) = PSPEC(JFLD,INM+2) + PIA(J ,II) + PSPEC(JFLD,INM+3) = PSPEC(JFLD,INM+3) + PIA(J+1,II) + + ENDDO + ENDDO +ENDIF +IF (LHOOK) CALL DR_HOOK('EPRFI1BAD_MOD:EPRFI1BAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI1BAD +END MODULE EPRFI1BAD_MOD diff --git a/src/etrans/etrans/internal/eprfi2_mod.F90 b/src/etrans/etrans/internal/eprfi2_mod.F90 new file mode 100644 index 000000000..35c418bf1 --- /dev/null +++ b/src/etrans/etrans/internal/eprfi2_mod.F90 @@ -0,0 +1,85 @@ +MODULE EPRFI2_MOD +CONTAINS +SUBROUTINE EPRFI2(KM,KMLOC,KF_FS,PFFT) + +!**** *EPRFI2* - Prepare input work arrays for direct transform + +! Purpose. +! -------- +! To extract the Fourier fields for a specific zonal wavenumber +! and put them in an order suitable for the direct Legendre +! tranforms, i.e. split into symmetric and anti-symmetric part. + +!** Interface. +! ---------- +! *CALL* *EPRFI2(..) + +! Explicit arguments : +! -------------------- KM - zonal wavenumber +! KMLOC - local zonal wavenumber +! PAIA - antisymmetric part of Fourier +! components for KM (output) +! PSIA - symmetric part of Fourier +! components for KM (output) + +! Implicit arguments : The Grid point arrays of the model. +! -------------------- + +! Method. +! ------- + +! Externals. PRFI2B - basic copying routine +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 87-11-25 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified : 93-03-19 D. Giard - CDCONF='T' +! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' +! Modified : 93-05-13 D. Giard - correction of the previous bug +! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer +! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' +! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div +! instead of u,v->vor,div +! MPP Group: 95-10-01 Support for Distributed Memory version +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +!USE TPM_TRANS + +USE EPRFI2B_MOD ,ONLY : EPRFI2B +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) , INTENT(IN) :: KM +INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC +INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS + +REAL(KIND=JPRB) , INTENT(OUT) :: PFFT(:,:) + +! ------------------------------------------------------------------ + +!* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. +! ------------------------------------------- + +CALL EPRFI2B(KF_FS,KM,KMLOC,PFFT) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI2 +END MODULE EPRFI2_MOD diff --git a/src/etrans/etrans/internal/eprfi2ad_mod.F90 b/src/etrans/etrans/internal/eprfi2ad_mod.F90 new file mode 100644 index 000000000..186dc29e4 --- /dev/null +++ b/src/etrans/etrans/internal/eprfi2ad_mod.F90 @@ -0,0 +1,82 @@ +MODULE EPRFI2AD_MOD +CONTAINS +SUBROUTINE EPRFI2AD(KM,KMLOC,KF_FS,PFFT) + +!**** *EPRFI2AD* - Prepare input work arrays for direct transform + +! Purpose. +! -------- +! To extract the Fourier fields for a specific zonal wavenumber +! and put them in an order suitable for the direct Legendre +! tranforms, i.e. split into symmetric and anti-symmetric part. + +!** Interface. +! ---------- +! *CALL* *EPRFI2AD(..) + +! Explicit arguments : +! -------------------- KM - zonal wavenumber +! KMLOC - local zonal wavenumber +! PAIA - antisymmetric part of Fourier +! components for KM (output) +! PSIA - symmetric part of Fourier +! components for KM (output) + +! Implicit arguments : The Grid point arrays of the model. +! -------------------- + +! Method. +! ------- + +! Externals. EPRFI2BAD - basic copying routine +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 87-11-25 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified : 93-03-19 D. Giard - CDCONF='T' +! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' +! Modified : 93-05-13 D. Giard - correction of the previous bug +! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer +! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' +! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div +! instead of u,v->vor,div +! MPP Group: 95-10-01 Support for Distributed Memory version +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +USE EPRFI2BAD_MOD ,ONLY : EPRFI2BAD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) , INTENT(IN) :: KM +INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC +INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS + +REAL(KIND=JPRB) , INTENT(IN) :: PFFT(:,:) + +! ------------------------------------------------------------------ + +!* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. +! ------------------------------------------- + +CALL EPRFI2BAD(KF_FS,KM,KMLOC,PFFT) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI2AD +END MODULE EPRFI2AD_MOD diff --git a/src/etrans/etrans/internal/eprfi2b_mod.F90 b/src/etrans/etrans/internal/eprfi2b_mod.F90 new file mode 100644 index 000000000..6c304d81c --- /dev/null +++ b/src/etrans/etrans/internal/eprfi2b_mod.F90 @@ -0,0 +1,92 @@ +MODULE EPRFI2B_MOD +CONTAINS +SUBROUTINE EPRFI2B(KFIELD,KM,KMLOC,PFFT) + +!**** *EPRFI2B* - Prepare input work arrays for direct transform + +! Purpose. +! -------- +! To extract the Fourier fields for a specific zonal wavenumber +! and put them in an order suitable for the direct Legendre +! tranforms, i.e. split into symmetric and anti-symmetric part. + +!** Interface. +! ---------- +! *CALL* *EPRFI2B(..) + +! Explicit arguments : +! ------------------- KFIELD - number of fields +! KM - zonal wavenumber +! KMLOC - local zonal wavenumber +! PAOA - antisymmetric part of Fourier +! fields for zonal wavenumber KM +! PSOA - symmetric part of Fourier +! fields for zonal wavenumber KM + +! Implicit arguments : FOUBUF in TPM_TRANS +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 90-07-01 +! MPP Group: 95-10-01 Support for Distributed Memory version +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPM_TRANS ,ONLY : FOUBUF +!USE TPM_GEOMETRY +USE TPM_DISTR ,ONLY : D +!USE TPMALD_DIM ,ONLY : RALD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD,KM,KMLOC +REAL(KIND=JPRB) , INTENT(OUT) :: PFFT(:,:) +INTEGER(KIND=JPIM) :: ISTAN, JF, JGL +INTEGER(KIND=JPIM) :: IJR,IJI +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EPRFI2B_MOD:EPRFI2B',0,ZHOOK_HANDLE) + +!* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. +! ------------------------------------------------ + +!DIR$ IVDEP +!OCL NOVREC +DO JGL=1,R%NDGL + ISTAN = (D%NSTAGT1B(D%NPROCL(JGL) )+D%NPNTGTB1(KMLOC,JGL ))*2*KFIELD + DO JF =1,KFIELD + IJR = 2*(JF-1)+1 + IJI = IJR+1 + PFFT(JGL,IJR) = FOUBUF(ISTAN+IJR) + PFFT(JGL,IJI) = FOUBUF(ISTAN+IJI) + ENDDO +ENDDO +IF (LHOOK) CALL DR_HOOK('EPRFI2B_MOD:EPRFI2B',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI2B +END MODULE EPRFI2B_MOD diff --git a/src/etrans/etrans/internal/eprfi2bad_mod.F90 b/src/etrans/etrans/internal/eprfi2bad_mod.F90 new file mode 100644 index 000000000..40865662b --- /dev/null +++ b/src/etrans/etrans/internal/eprfi2bad_mod.F90 @@ -0,0 +1,90 @@ +MODULE EPRFI2BAD_MOD +CONTAINS +SUBROUTINE EPRFI2BAD(KFIELD,KM,KMLOC,PFFT) + +!**** *EPRFI2BAD* - Prepare input work arrays for direct transform + +! Purpose. +! -------- +! To extract the Fourier fields for a specific zonal wavenumber +! and put them in an order suitable for the direct Legendre +! tranforms, i.e. split into symmetric and anti-symmetric part. + +!** Interface. +! ---------- +! *CALL* *EPRFI2BAD(..) + +! Explicit arguments : +! ------------------- KFIELD - number of fields +! KM - zonal wavenumber +! KMLOC - local zonal wavenumber +! PAOA - antisymmetric part of Fourier +! fields for zonal wavenumber KM +! PSOA - symmetric part of Fourier +! fields for zonal wavenumber KM + +! Implicit arguments : FOUBUF in TPM_TRANS +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 90-07-01 +! MPP Group: 95-10-01 Support for Distributed Memory version +! Modified : 04/06/99 D.Salmond : change order of AIA and SIA +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +!USE TPMALD_DIM ,ONLY : RALD +USE TPM_TRANS ,ONLY : FOUBUF +!USE TPM_GEOMETRY +USE TPM_DISTR ,ONLY : D +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD,KM,KMLOC +REAL(KIND=JPRB) , INTENT(IN) :: PFFT(:,:) + +INTEGER(KIND=JPIM) :: ISTAN, JF, JGL + +INTEGER(KIND=JPIM) :: IJR,IJI +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. +! ------------------------------------------------ +IF (LHOOK) CALL DR_HOOK('EPRFI2BAD_MOD:EPRFI2BAD',0,ZHOOK_HANDLE) +DO JGL=1,R%NDGL + ISTAN = (D%NSTAGT1B(D%NPROCL(JGL) )+D%NPNTGTB1(KMLOC,JGL ))*2*KFIELD + DO JF =1,KFIELD + IJR = 2*(JF-1)+1 + IJI = IJR+1 + FOUBUF(ISTAN+IJR) = PFFT(JGL,IJR) + FOUBUF(ISTAN+IJI) = PFFT(JGL,IJI) + ENDDO +ENDDO +IF (LHOOK) CALL DR_HOOK('EPRFI2BAD_MOD:EPRFI2BAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EPRFI2BAD +END MODULE EPRFI2BAD_MOD diff --git a/src/etrans/etrans/internal/eset_resol_mod.F90 b/src/etrans/etrans/internal/eset_resol_mod.F90 new file mode 100644 index 000000000..b5f1434a8 --- /dev/null +++ b/src/etrans/etrans/internal/eset_resol_mod.F90 @@ -0,0 +1,71 @@ +MODULE ESET_RESOL_MOD +CONTAINS +SUBROUTINE ESET_RESOL(KRESOL) +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NOUT, MSETUP0, NCUR_RESOL, NMAX_RESOL +USE TPM_DIM ,ONLY : R, DIM_RESOL +!USE TPM_TRANS +USE TPM_DISTR ,ONLY : D, DISTR_RESOL +USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL +USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL +USE TPM_FFT ,ONLY : T, FFT_RESOL, TB, FFTB_RESOL +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, FFTW_RESOL +#endif + +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + +USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL +USE TPMALD_DISTR ,ONLY : DALD, ALDDISTR_RESOL +USE TPMALD_FFT ,ONLY : TALD, ALDFFT_RESOL +USE TPMALD_FIELDS ,ONLY : FALD, ALDFIELDS_RESOL +USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL +! + +IMPLICIT NONE + +! Declaration of arguments + +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL + +! Local varaibles +INTEGER(KIND=JPIM) :: IRESOL +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ESET_RESOL_MOD:ESET_RESOL',0,ZHOOK_HANDLE) +IF(MSETUP0 == 0) CALL ABORT_TRANS('ESET_RESOL:TRANS NOT SETUP') +IRESOL = 1 +IF(PRESENT(KRESOL)) THEN + IRESOL = KRESOL + IF(KRESOL < 1 .OR. KRESOL > NMAX_RESOL) THEN + WRITE(NOUT,*)'ESET_RESOL: UNKNOWN RESOLUTION ',KRESOL,NMAX_RESOL + CALL ABORT_TRANS('ESET_RESOL:KRESOL < 1 .OR. KRESOL > NMAX_RESOL') + ENDIF +ENDIF +IF(IRESOL /= NCUR_RESOL) THEN + NCUR_RESOL = IRESOL + R => DIM_RESOL(NCUR_RESOL) + F => FIELDS_RESOL(NCUR_RESOL) + G => GEOM_RESOL(NCUR_RESOL) + D => DISTR_RESOL(NCUR_RESOL) + T => FFT_RESOL(NCUR_RESOL) + TB => FFTB_RESOL(NCUR_RESOL) +#ifdef WITH_FFTW + TW => FFTW_RESOL(NCUR_RESOL) +#endif + + RALD => ALDDIM_RESOL(NCUR_RESOL) + DALD => ALDDISTR_RESOL(NCUR_RESOL) + TALD => ALDFFT_RESOL(NCUR_RESOL) + FALD => ALDFIELDS_RESOL(NCUR_RESOL) + GALD => ALDGEO_RESOL(NCUR_RESOL) + +ENDIF +IF (LHOOK) CALL DR_HOOK('ESET_RESOL_MOD:ESET_RESOL',1,ZHOOK_HANDLE) + +END SUBROUTINE ESET_RESOL +END MODULE ESET_RESOL_MOD diff --git a/src/etrans/etrans/internal/esetup_dims_mod.F90 b/src/etrans/etrans/internal/esetup_dims_mod.F90 new file mode 100644 index 000000000..077f2740f --- /dev/null +++ b/src/etrans/etrans/internal/esetup_dims_mod.F90 @@ -0,0 +1,46 @@ +MODULE ESETUP_DIMS_MOD +CONTAINS +SUBROUTINE ESETUP_DIMS + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPMALD_DIM ,ONLY : RALD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: JM,JN,ISPOLEG +INTEGER(KIND=JPIM) :: ISMAX(0:R%NSMAX),ISNAX(0:RALD%NMSMAX) +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ESETUP_DIMS_MOD:ESETUP_DIMS',0,ZHOOK_HANDLE) +ISPOLEG = 0 +DO JM=0,R%NSMAX + DO JN=JM,R%NTMAX+1 + ISPOLEG = ISPOLEG+1 + ENDDO +ENDDO +R%NSPOLEG = ISPOLEG +CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) +R%NSPEC_G=0 +DO JM=0,RALD%NMSMAX + R%NSPEC_G=R%NSPEC_G+2*(ISNAX(JM)+1) +ENDDO +R%NSPEC2_G = R%NSPEC_G*2 + +R%NDGNH = (R%NDGL+1)/2 + +R%NLEI1 = R%NSMAX+4+MOD(R%NSMAX+4+1,2) +R%NLEI3 = R%NDGNH+MOD(R%NDGNH+2,2) + +R%NLED3 = R%NTMAX+2+MOD(R%NTMAX+3,2) +R%NLED4 = R%NTMAX+3+MOD(R%NTMAX+4,2) +IF (LHOOK) CALL DR_HOOK('ESETUP_DIMS_MOD:ESETUP_DIMS',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ESETUP_DIMS +END MODULE ESETUP_DIMS_MOD diff --git a/src/etrans/etrans/internal/esetup_geom_mod.F90 b/src/etrans/etrans/internal/esetup_geom_mod.F90 new file mode 100644 index 000000000..a93c67d24 --- /dev/null +++ b/src/etrans/etrans/internal/esetup_geom_mod.F90 @@ -0,0 +1,66 @@ +MODULE ESETUP_GEOM_MOD +CONTAINS +SUBROUTINE ESETUP_GEOM + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NOUT, NPRINTLEV +USE TPM_DIM ,ONLY : R +USE TPM_DISTR ,ONLY : D +USE TPMALD_DIM ,ONLY : RALD +!USE TPM_FIELDS +USE TPM_GEOMETRY ,ONLY : G +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: IDGLU(0:RALD%NMSMAX,R%NDGNH) +INTEGER(KIND=JPIM) :: JGL,JM + +LOGICAL :: LLP1,LLP2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ESETUP_GEOM_MOD:ESETUP_GEOM',0,ZHOOK_HANDLE) +IF(.NOT.D%LGRIDONLY) THEN +LLP1 = NPRINTLEV>0 +LLP2 = NPRINTLEV>1 + +IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SETUP_GEOM ===' + +ALLOCATE (G%NMEN(R%NDGL)) +IF(LLP2)WRITE(NOUT,9) 'G%NMEN ',SIZE(G%NMEN ),SHAPE(G%NMEN ) +G%NMEN(:)=RALD%NMSMAX +IF(LLP1) THEN + WRITE(NOUT,FMT='('' (JGL,G%NLOEN,G%NMEN) '')') + WRITE(NOUT,FMT='(8(1X,''('',I4,I4,I4,'')''))')& + & (JGL,G%NLOEN(JGL),G%NMEN(JGL),JGL=1,R%NDGL) +ENDIF +ALLOCATE(G%NDGLU(0:RALD%NMSMAX)) +IF(LLP2)WRITE(NOUT,9) 'G%NDGLU ',SIZE(G%NDGLU ),SHAPE(G%NDGLU ) +IDGLU(:,:) = 0 +G%NDGLU(:) = 0 +DO JGL=1,R%NDGNH + DO JM=0,G%NMEN(JGL) + IDGLU(JM,JGL) = 1 + ENDDO +ENDDO +DO JM=0,RALD%NMSMAX + DO JGL=1,R%NDGNH + G%NDGLU(JM) = G%NDGLU(JM)+IDGLU(JM,JGL) + ENDDO +ENDDO +IF(LLP1) THEN + WRITE(NOUT,FMT='('' (JM,G%NDGLU) '')') + WRITE(NOUT,FMT='(10(1X,''('',I4,I4,'')''))')& + & (JM,G%NDGLU(JM),JM=0,RALD%NMSMAX) +ENDIF +ENDIF +IF (LHOOK) CALL DR_HOOK('ESETUP_GEOM_MOD:ESETUP_GEOM',1,ZHOOK_HANDLE) +! ------------------------------------------------------------------ +9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) + +END SUBROUTINE ESETUP_GEOM +END MODULE ESETUP_GEOM_MOD diff --git a/src/etrans/etrans/internal/espnorm_ctl_mod.F90 b/src/etrans/etrans/internal/espnorm_ctl_mod.F90 new file mode 100644 index 000000000..6e0ad3aae --- /dev/null +++ b/src/etrans/etrans/internal/espnorm_ctl_mod.F90 @@ -0,0 +1,64 @@ +MODULE ESPNORM_CTL_MOD +CONTAINS +SUBROUTINE ESPNORM_CTL(PSPEC,KFLD,KFLD_G,KVSET,KMASTER,PMET,PNORM) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPM_DISTR ,ONLY : D, MYSETV, MYPROC + +USE ESPNORMD_MOD ,ONLY : ESPNORMD +USE SPNORMC_MOD ,ONLY : SPNORMC + +USE TPMALD_DIM ,ONLY : RALD +! + +IMPLICIT NONE + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) +INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER +REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PNORM(:) +INTEGER(KIND=JPIM) , INTENT(IN) :: KFLD,KFLD_G +INTEGER(KIND=JPIM) :: IVSET(KFLD_G) + +REAL(KIND=JPRB) :: ZMET(0:R%NSPEC_G) + +REAL(KIND=JPRB) :: ZSM(KFLD,D%NUMP) + +REAL(KIND=JPRB) :: ZGM(KFLD_G,0:RALD%NMSMAX) +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE1 + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:ESPNORM_CTL',0,ZHOOK_HANDLE) +IF(PRESENT(KVSET)) THEN + IVSET(:) = KVSET(:) +ELSE + IVSET(:) = MYSETV +ENDIF + +IF(PRESENT(PMET)) THEN + ZMET(:) = PMET(:) +ELSE + ZMET(:) = 1.0_JPRB +ENDIF + +CALL ESPNORMD(PSPEC,KFLD,ZMET,ZSM) + +IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:SPNORMC',0,ZHOOK_HANDLE1) +CALL SPNORMC(ZSM,KFLD_G,IVSET,KMASTER,RALD%NMSMAX,ZGM) +IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:SPNORMC',1,ZHOOK_HANDLE1) + +IF(MYPROC == KMASTER) THEN + PNORM(1:KFLD_G) = SUM(ZGM,DIM=2) + PNORM(1:KFLD_G) = SQRT(PNORM(1:KFLD_G)) +ENDIF +IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:ESPNORM_CTL',1,ZHOOK_HANDLE) +! ------------------------------------------------------------------ + +END SUBROUTINE ESPNORM_CTL +END MODULE ESPNORM_CTL_MOD diff --git a/src/etrans/etrans/internal/espnormc_mod.F90 b/src/etrans/etrans/internal/espnormc_mod.F90 new file mode 100644 index 000000000..4b56285f6 --- /dev/null +++ b/src/etrans/etrans/internal/espnormc_mod.F90 @@ -0,0 +1,3 @@ +MODULE ESPNORMC_MOD + ! dead code +END MODULE ESPNORMC_MOD diff --git a/src/etrans/etrans/internal/espnormd_mod.F90 b/src/etrans/etrans/internal/espnormd_mod.F90 new file mode 100644 index 000000000..75e245add --- /dev/null +++ b/src/etrans/etrans/internal/espnormd_mod.F90 @@ -0,0 +1,55 @@ +MODULE ESPNORMD_MOD +CONTAINS +SUBROUTINE ESPNORMD(PSPEC,KFLD,PMET,PSM) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPM_DISTR ,ONLY : D + +USE TPMALD_DISTR ,ONLY : DALD +! + +IMPLICIT NONE + +REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) +REAL(KIND=JPRB) ,INTENT(IN) :: PMET(0:R%NSPEC_G) +INTEGER(KIND=JPIM) ,INTENT(IN) :: KFLD +REAL(KIND=JPRB) ,INTENT(OUT) :: PSM(:,:) +INTEGER(KIND=JPIM) :: JM ,JFLD ,JN ,IM ,ISP +INTEGER(KIND=JPIM) :: IN,ISPE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('ESPNORMD_MOD:ESPNORMD',0,ZHOOK_HANDLE) + +!$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JM,IM,JN,ISP,JFLD,IN,ISPE) +DO JM=1,D%NUMP + PSM(:,JM) = 0.0_JPRB + IM = D%MYMS(JM) + + IN=DALD%NCPL2M(IM)/2 - 1 + DO JN=0,IN + ISP=DALD%NESM0(IM) + (JN)*4 + ISPE=DALD%NPME (IM) + JN + DO JFLD=1,KFLD + PSM(JFLD,JM) =PSM(JFLD,JM)& + & + PMET(ISPE) *& + & ( PSPEC(JFLD,ISP )**2 + PSPEC(JFLD,ISP+1)**2 +& + & PSPEC(JFLD,ISP+2)**2 + PSPEC(JFLD,ISP+3)**2 ) + + ENDDO + ENDDO + +ENDDO +!$OMP END PARALLEL DO + +IF (LHOOK) CALL DR_HOOK('ESPNORMD_MOD:ESPNORMD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ESPNORMD +END MODULE ESPNORMD_MOD + diff --git a/src/etrans/etrans/internal/espnsde_mod.F90 b/src/etrans/etrans/internal/espnsde_mod.F90 new file mode 100644 index 000000000..9160e61ce --- /dev/null +++ b/src/etrans/etrans/internal/espnsde_mod.F90 @@ -0,0 +1,101 @@ +MODULE ESPNSDE_MOD +CONTAINS +SUBROUTINE ESPNSDE(KM,KF_SCALARS,PF,PNSD) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_GEN +!USE TPM_DIM +!USE TPM_FIELDS +!USE TPM_TRANS +USE TPMALD_DISTR ,ONLY : DALD +USE TPMALD_GEO ,ONLY : GALD + + +!**** *SPNSDE* - Compute North-South derivative in spectral space + +! Purpose. +! -------- +! In Laplace space compute the the North-south derivative + +!** Interface. +! ---------- +! CALL SPNSDE(...) + +! Explicit arguments : +! -------------------- +! KM -zonal wavenumber (input-c) +! PEPSNM - REPSNM for wavenumber KM (input-c) +! PF (NLEI1,2*KF_SCALARS) - input field (input) +! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) + +! Organisation within NLEI1: +! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) +! overdimensioning +! 1 : n=NSMAX+2 +! 2 : n=NSMAX+1 +! 3 : n=NSMAX +! . : +! . : +! NSMAX+3 : n=0 +! NSMAX+4 : n=-1 + +! Implicit arguments : YOMLAP +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS +! Temperton, 1991, MWR 119 p1303 + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From SPNSDE in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +REAL(KIND=JPRB), INTENT(IN) :: PF(:,:) +REAL(KIND=JPRB), INTENT(OUT) :: PNSD(:,:) + +INTEGER(KIND=JPIM) :: J, JN,IN +REAL(KIND=JPRB) :: ZIN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. COMPUTE NORTH SOUTH DERIVATIVE. +! ------------------------------- + +!* 1.1 COMPUTE + +IF (LHOOK) CALL DR_HOOK('ESPNSDE_MOD:ESPNSDE',0,ZHOOK_HANDLE) +DO JN=1,DALD%NCPL2M(KM),2 + IN =(JN-1)/2 + ZIN = REAL(IN,JPRB)*GALD%EYWN + DO J=1,2*KF_SCALARS + PNSD(JN ,J) = -ZIN*PF(JN+1,J) + PNSD(JN+1,J) = ZIN*PF(JN,J) + ENDDO +ENDDO +IF (LHOOK) CALL DR_HOOK('ESPNSDE_MOD:ESPNSDE',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ESPNSDE +END MODULE ESPNSDE_MOD diff --git a/src/etrans/etrans/internal/espnsdead_mod.F90 b/src/etrans/etrans/internal/espnsdead_mod.F90 new file mode 100644 index 000000000..3ca9ded9c --- /dev/null +++ b/src/etrans/etrans/internal/espnsdead_mod.F90 @@ -0,0 +1,112 @@ +MODULE ESPNSDEAD_MOD +CONTAINS +SUBROUTINE ESPNSDEAD(KM,KF_SCALARS,PF,PNSD) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_GEN +!USE TPM_DIM +!USE TPM_FIELDS +!USE TPM_TRANS + +USE TPMALD_DISTR ,ONLY : DALD +USE TPMALD_GEO ,ONLY : GALD + + +!**** *ESPNSDEAD* - Compute North-South derivative in spectral space + +! Purpose. +! -------- +! In Laplace space compute the the North-south derivative + +!** Interface. +! ---------- +! CALL ESPNSDEAD(...) + +! Explicit arguments : +! -------------------- +! KM -zonal wavenumber (input-c) +! PEPSNM - REPSNM for wavenumber KM (input-c) +! PF (NLEI1,2*KF_SCALARS) - input field (input) +! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) + +! Organisation within NLEI1: +! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) +! overdimensioning +! 1 : n=NSMAX+2 +! 2 : n=NSMAX+1 +! 3 : n=NSMAX +! . : +! . : +! NSMAX+3 : n=0 +! NSMAX+4 : n=-1 + +! Implicit arguments : YOMLAP +! -------------------- + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS +! Temperton, 1991, MWR 119 p1303 + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From SPNSDEAD in IFS CY22R1 +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS +REAL(KIND=JPRB), INTENT(INOUT) :: PF(:,:) +REAL(KIND=JPRB), INTENT(IN) :: PNSD(:,:) +INTEGER(KIND=JPIM) :: ISKIP, J, JN +INTEGER(KIND=JPIM) :: IN +REAL(KIND=JPRB) :: ZIN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. COMPUTE NORTH SOUTH DERIVATIVE. +! ------------------------------- + +!* 1.1 COMPUTE + +IF (LHOOK) CALL DR_HOOK('ESPNSDEAD_MOD:ESPNSDEAD',0,ZHOOK_HANDLE) +IF(KM == 0) THEN + ISKIP = 1 +ELSE + ISKIP = 1 +ENDIF + +DO JN=1,DALD%NCPL2M(KM),2 + + IN = (JN-1)/2 + ZIN = REAL(IN,JPRB)*GALD%EYWN + + DO J=1,2*KF_SCALARS,ISKIP + + PF(JN+1,J) = PF(JN+1,J)-ZIN*PNSD(JN ,J) + PF(JN ,J) = PF(JN ,J)+ZIN*PNSD(JN+1,J) + + ENDDO +ENDDO +IF (LHOOK) CALL DR_HOOK('ESPNSDEAD_MOD:ESPNSDEAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE ESPNSDEAD +END MODULE ESPNSDEAD_MOD diff --git a/src/etrans/etrans/internal/eupdsp_mod.F90 b/src/etrans/etrans/internal/eupdsp_mod.F90 new file mode 100644 index 000000000..210ac4fc5 --- /dev/null +++ b/src/etrans/etrans/internal/eupdsp_mod.F90 @@ -0,0 +1,141 @@ +MODULE EUPDSP_MOD +CONTAINS +SUBROUTINE EUPDSP(KM,KF_UV,KF_SCALARS,PFFT,PVODI, & + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC) + +!**** *EUPDSP* - Update spectral arrays after direct Legendre transform + +! Purpose. +! -------- +! To update the spectral arrays for a fixed zonal wave-number +! from values in POA1 and POA2. + +!** Interface. +! ---------- +! CALL EUPDSP(...) + +! Explicit arguments : +! -------------------- +! KM - zonal wave-number +! POA1 - spectral fields for zonal wavenumber KM (basic var.) +! POA2 - spectral fields for zonal wavenumber KM (vor. div.) +! PSPVOR - spectral vorticity +! PSPDIV - spectral divergence +! PSPSCALAR - spectral scalar variables + +! Implicit arguments : +! -------------------- + +! Method. +! ------- + +! Externals. UPDSPB - basic transfer routine +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 88-02-02 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified : 94-08-02 R. El Khatib - interface to UPDSPB +! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div +! instead of u,v->vor,div +! MPP Group: 95-10-01 Support for Distributed Memory version +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B +!USE TPM_DISTR + +USE EUPDSPB_MOD ,ONLY : EUPDSPB +! + +IMPLICIT NONE + + +INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV,KF_SCALARS +REAL(KIND=JPRB) , INTENT(IN) :: PFFT(:,:) +REAL(KIND=JPRB) , INTENT(IN) :: PVODI(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) + +INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND,IDIM1,IDIM3,J3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. UPDATE FIELDS +! ------------- + +!* 1.1 VORTICITY AND DIVERGENCE. + +IF (LHOOK) CALL DR_HOOK('EUPDSP_MOD:EUPDSP',0,ZHOOK_HANDLE) +IST = 1 +IF (KF_UV > 0) THEN + IST = IST+4*KF_UV + IVORS = 1 + IVORE = 2*KF_UV + IDIVS = 2*KF_UV+1 + IDIVE = 4*KF_UV + CALL EUPDSPB(KM,KF_UV,PVODI(:,IVORS:IVORE),PSPVOR,KFLDPTRUV) + CALL EUPDSPB(KM,KF_UV,PVODI(:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) +ENDIF + +!* 1.2 SCALARS + +IF (KF_SCALARS > 0) THEN + IF(PRESENT(PSPSCALAR)) THEN + IEND = IST+2*KF_SCALARS-1 + CALL EUPDSPB(KM,KF_SCALARS,PFFT(:,IST:IEND),PSPSCALAR,KFLDPTRSC) + ELSE + IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN + IDIM1 = NF_SC2 + IEND = IST+2*IDIM1-1 + CALL EUPDSPB(KM,IDIM1,PFFT(:,IST:IEND),PSPSC2) + IST=IST+2*IDIM1 + ENDIF + IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN + IDIM1=NF_SC3A + IDIM3=UBOUND(PSPSC3A,3) + DO J3=1,IDIM3 + IEND = IST+2*IDIM1-1 + CALL EUPDSPB(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3A(:,:,J3)) + IST=IST+2*IDIM1 + ENDDO + ENDIF + IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN + IDIM1=NF_SC3B + IDIM3=UBOUND(PSPSC3B,3) + DO J3=1,IDIM3 + IEND = IST+2*IDIM1-1 + CALL EUPDSPB(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3B(:,:,J3)) + IST=IST+2*IDIM1 + ENDDO + ENDIF + ENDIF +ENDIF +IF (LHOOK) CALL DR_HOOK('EUPDSP_MOD:EUPDSP',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EUPDSP +END MODULE EUPDSP_MOD diff --git a/src/etrans/etrans/internal/eupdspad_mod.F90 b/src/etrans/etrans/internal/eupdspad_mod.F90 new file mode 100644 index 000000000..8f1699a1a --- /dev/null +++ b/src/etrans/etrans/internal/eupdspad_mod.F90 @@ -0,0 +1,145 @@ +MODULE EUPDSPAD_MOD +CONTAINS +SUBROUTINE EUPDSPAD(KM,KF_UV,KF_SCALARS,PFFT,PVODI, & + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC) + +!**** *EUPDSPAD* - Update spectral arrays after direct Legendre transform + +! Purpose. +! -------- +! To update the spectral arrays for a fixed zonal wave-number +! from values in POA1 and POA2. + +!** Interface. +! ---------- +! CALL EUPDSPAD(...) + +! Explicit arguments : +! -------------------- +! KM - zonal wave-number +! POA1 - spectral fields for zonal wavenumber KM (basic var.) +! POA2 - spectral fields for zonal wavenumber KM (vor. div.) +! PSPVOR - spectral vorticity +! PSPDIV - spectral divergence +! PSPSCALAR - spectral scalar variables + +! Implicit arguments : +! -------------------- + +! Method. +! ------- + +! Externals. UPDSPADB - basic transfer routine +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 88-02-02 +! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite +! for uv formulation +! Modified : 94-08-02 R. El Khatib - interface to UPDSPADB +! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div +! instead of u,v->vor,div +! MPP Group: 95-10-01 Support for Distributed Memory version +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DIM +USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B +!USE TPM_DISTR + +USE EUPDSPBAD_MOD ,ONLY : EUPDSPBAD +! + +IMPLICIT NONE + + +INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV,KF_SCALARS + +REAL(KIND=JPRB) , INTENT(OUT) :: PFFT(:,:) +REAL(KIND=JPRB) , INTENT(OUT) :: PVODI(:,:) + +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) +REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) +INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) + +INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND +INTEGER(KIND=JPIM) :: IDIM1,IDIM3,J3 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. UPDATE FIELDS +! ------------- + +!* 1.1 VORTICITY AND DIVERGENCE. + +IF (LHOOK) CALL DR_HOOK('EUPDSPAD_MOD:EUPDSPAD',0,ZHOOK_HANDLE) +IST = 1 +IF (KF_UV > 0) THEN + IST = IST+4*KF_UV + IVORS = 1 + IVORE = 2*KF_UV + IDIVS = 2*KF_UV+1 + IDIVE = 4*KF_UV + CALL EUPDSPBAD(KM,KF_UV,PVODI(:,IVORS:IVORE),PSPVOR,KFLDPTRUV) + CALL EUPDSPBAD(KM,KF_UV,PVODI(:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) +ENDIF + +!* 1.2 SCALARS + +IF (KF_SCALARS > 0) THEN + IF(PRESENT(PSPSCALAR)) THEN + IEND = IST+2*KF_SCALARS-1 + CALL EUPDSPBAD(KM,KF_SCALARS,PFFT(:,IST:IEND),PSPSCALAR,KFLDPTRSC) + ELSE + IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN + IDIM1 = NF_SC2 + IEND = IST+2*IDIM1-1 + CALL EUPDSPBAD(KM,IDIM1,PFFT(:,IST:IEND),PSPSC2) + IST=IST+2*IDIM1 + ENDIF + IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN + IDIM1=NF_SC3A + IDIM3=UBOUND(PSPSC3A,3) + DO J3=1,IDIM3 + IEND = IST+2*IDIM1-1 + CALL EUPDSPBAD(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3A(:,:,J3)) + IST=IST+2*IDIM1 + ENDDO + ENDIF + IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN + IDIM1=NF_SC3B + IDIM3=UBOUND(PSPSC3B,3) + DO J3=1,IDIM3 + IEND = IST+2*IDIM1-1 + CALL EUPDSPBAD(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3B(:,:,J3)) + IST=IST+2*IDIM1 + ENDDO + ENDIF + ENDIF +ENDIF +IF (LHOOK) CALL DR_HOOK('EUPDSPAD_MOD:EUPDSPAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EUPDSPAD +END MODULE EUPDSPAD_MOD diff --git a/src/etrans/etrans/internal/eupdspb_mod.F90 b/src/etrans/etrans/internal/eupdspb_mod.F90 new file mode 100644 index 000000000..37601c8f2 --- /dev/null +++ b/src/etrans/etrans/internal/eupdspb_mod.F90 @@ -0,0 +1,105 @@ +MODULE EUPDSPB_MOD +CONTAINS +SUBROUTINE EUPDSPB(KM,KFIELD,POA,PSPEC,KFLDPTR) + +!**** *EUPDSPB* - Update spectral arrays after direct Legendre transform + +! Purpose. +! -------- +! To update spectral arrays for a fixed zonal wave-number +! from values in POA. + +!** Interface. +! ---------- +! CALL EUPDSPB(....) + +! Explicit arguments : KM - zonal wavenumber +! -------------------- KFIELD - number of fields +! POA - work array +! PSPEC - spectral array + +! Implicit arguments : None +! -------------------- + +! Method. +! ------- + +! Externals. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 88-02-02 +! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) +! R. El Khatib : 94-08-02 Replace number of fields by indexes of the +! first and last field +! L. Isaksen : 95-06-06 Reordering of spectral arrays +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DIM +!USE TPM_FIELDS +!USE TPM_DISTR +USE TPMALD_DISTR ,ONLY : DALD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELD +REAL(KIND=JPRB) ,INTENT(IN) :: POA(:,:) +REAL(KIND=JPRB) ,INTENT(OUT) :: PSPEC(:,:) +INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) + +INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN,IFLD +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 1. UPDATE SPECTRAL FIELDS. +! ----------------------- +IF (LHOOK) CALL DR_HOOK('EUPDSPB_MOD:EUPDSPB',0,ZHOOK_HANDLE) +IF(PRESENT(KFLDPTR)) THEN + DO JN=1,DALD%NCPL2M(KM),2 + INM=DALD%NESM0(KM)+(JN-1)*2 + DO JFLD=1,KFIELD + IR= 2*JFLD-1 + II=IR+1 + IFLD = KFLDPTR(JFLD) + PSPEC(IFLD,INM) =POA(JN,IR) + PSPEC(IFLD,INM+1) =POA(JN+1,IR) + PSPEC(IFLD,INM+2) =POA(JN,II) + PSPEC(IFLD,INM+3) =POA(JN+1,II) + ENDDO + ENDDO +ELSE + DO JN=1,DALD%NCPL2M(KM),2 + INM=DALD%NESM0(KM)+(JN-1)*2 +! use unroll to provoke vectorization of outer loop +!cdir unroll=4 +!DIR$ IVDEP +!OCL NOVREC + DO JFLD=1,KFIELD + IR= 2*JFLD-1 + II=IR+1 + PSPEC(JFLD,INM) =POA(JN,IR) + PSPEC(JFLD,INM+1) =POA(JN+1,IR) + PSPEC(JFLD,INM+2) =POA(JN,II) + PSPEC(JFLD,INM+3) =POA(JN+1,II) + ENDDO + ENDDO +ENDIF +IF (LHOOK) CALL DR_HOOK('EUPDSPB_MOD:EUPDSPB',1,ZHOOK_HANDLE) + +END SUBROUTINE EUPDSPB +END MODULE EUPDSPB_MOD diff --git a/src/etrans/etrans/internal/eupdspbad_mod.F90 b/src/etrans/etrans/internal/eupdspbad_mod.F90 new file mode 100644 index 000000000..894f00260 --- /dev/null +++ b/src/etrans/etrans/internal/eupdspbad_mod.F90 @@ -0,0 +1,133 @@ +MODULE EUPDSPBAD_MOD +CONTAINS +SUBROUTINE EUPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) + +!**** *EUPDSPBAD* - Update spectral arrays after direct Legendre transform + +! Purpose. +! -------- +! To update spectral arrays for a fixed zonal wave-number +! from values in POA. + +!** Interface. +! ---------- +! CALL EUPDSPBAD(....) + +! Explicit arguments : KM - zonal wavenumber +! -------------------- KFIELD - number of fields +! POA - work array +! PSPEC - spectral array + +! Implicit arguments : None +! -------------------- + +! Method. +! ------- + +! Externals. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 88-02-02 +! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) +! R. El Khatib : 94-08-02 Replace number of fields by indexes of the +! first and last field +! L. Isaksen : 95-06-06 Reordering of spectral arrays +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DIM +!USE TPM_FIELDS +!USE TPM_DISTR + +USE TPMALD_DISTR ,ONLY : DALD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELD +REAL(KIND=JPRB) ,INTENT(OUT) :: POA(:,:) +REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) +INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) + +INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN,IFLD +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +!* 0. NOTE. +! ----- + +! The following transfer reads : +! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) +! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) +! with n from m to NSMAX +! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. +! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) +! nn is the loop index. + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EUPDSPBAD_MOD:EUPDSPBAD',0,ZHOOK_HANDLE) +POA(:,:) = 0.0_JPRB + +IF(PRESENT(KFLDPTR)) THEN + + DO JFLD=1,KFIELD + IR= 2*JFLD-1 + II=IR+1 + IFLD = KFLDPTR(JFLD) +!DIR$ IVDEP +!OCL NOVREC + DO JN=1,DALD%NCPL2M(KM),2 + INM=DALD%NESM0(KM)+(JN-1)*2 + POA(JN,IR) = PSPEC(IFLD,INM) + POA(JN+1,IR) = PSPEC(IFLD,INM+1) + POA(JN,II) = PSPEC(IFLD,INM+2) + POA(JN+1,II) = PSPEC(IFLD,INM+3) + PSPEC(IFLD,INM )= 0.0_JPRB + PSPEC(IFLD,INM+1)= 0.0_JPRB + PSPEC(IFLD,INM+2)= 0.0_JPRB + PSPEC(IFLD,INM+3)= 0.0_JPRB + ENDDO + ENDDO + +ELSE + + DO JN=1,DALD%NCPL2M(KM),2 + INM=DALD%NESM0(KM)+(JN-1)*2 +!DIR$ IVDEP +!OCL NOVREC + DO JFLD=1,KFIELD + IR= 2*JFLD-1 + II=IR+1 + POA(JN,IR) = PSPEC(JFLD,INM) + POA(JN+1,IR) = PSPEC(JFLD,INM+1) + POA(JN,II) = PSPEC(JFLD,INM+2) + POA(JN+1,II) = PSPEC(JFLD,INM+3) + PSPEC(JFLD,INM )= 0.0_JPRB + PSPEC(JFLD,INM+1)= 0.0_JPRB + PSPEC(JFLD,INM+2)= 0.0_JPRB + PSPEC(JFLD,INM+3)= 0.0_JPRB + ENDDO + ENDDO + +ENDIF +IF (LHOOK) CALL DR_HOOK('EUPDSPBAD_MOD:EUPDSPBAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EUPDSPBAD +END MODULE EUPDSPBAD_MOD diff --git a/src/etrans/etrans/internal/euvtvd_comm_mod.F90 b/src/etrans/etrans/internal/euvtvd_comm_mod.F90 new file mode 100644 index 000000000..44fa1fe02 --- /dev/null +++ b/src/etrans/etrans/internal/euvtvd_comm_mod.F90 @@ -0,0 +1,127 @@ +MODULE EUVTVD_COMM_MOD +CONTAINS +SUBROUTINE EUVTVD_COMM(KFIELD,PSPMEANU,PSPMEANV,KFLDPTR) + +!**** *EUVTVD_COMM* - Communicate mean wind + +! Purpose. +! -------- + +!** Interface. +! ---------- +! CALL EUVTVD_COMM(KFIELD,PSPMEANU,PSPMEANV,KFLDPTR) + +! Explicit arguments : +! -------------------- KFIELD - number of fields (levels) +! KFLDPTR - fields pointers + +! Method. See ref. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 91-07-01 +! D. Giard : NTMAX instead of NSMAX +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! 03-03-03 : G. Radnoti: b-level conform mean-wind distribution +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement +! R. El Khatib 12-Jan-2020 Fix missing finalization of communications +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM +USE TPM_FIELDS +USE TPM_DISTR +USE TPMALD_GEO +USE TPMALD_DISTR +USE MPL_MODULE +USE SET2PE_MOD +USE ABORT_TRANS_MOD +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD +REAL(KIND=JPRB), INTENT(INOUT) :: PSPMEANU(KFIELD) +REAL(KIND=JPRB), INTENT(INOUT) :: PSPMEANV(KFIELD) +INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(KFIELD) + +INTEGER(KIND=JPIM) :: J, JA,ITAG,ILEN,IFLD,ISND, IM, JM + +INTEGER(KIND=JPIM) :: ISENDREQ(NPRTRW) + +REAL(KIND=JPRB) :: ZSPU(2*KFIELD) + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EUVTVD_COMM_MOD:EUVTVD_COMM',0,ZHOOK_HANDLE) + +!* 1. COMMUNICATE MEAN WIND +! --------------------- + +IF (D%NPROCM(0) == MYSETW) THEN + IF (PRESENT(KFLDPTR)) THEN + DO J=1,KFIELD + IFLD=KFLDPTR(J) + ZSPU(J)=PSPMEANU(IFLD) + ZSPU(KFIELD+J)=PSPMEANV(IFLD) + ENDDO + ELSE + DO J=1,KFIELD + ZSPU(J)=PSPMEANU(J) + ZSPU(KFIELD+J)=PSPMEANV(J) + ENDDO + ENDIF + DO JA=1,NPRTRW + IF (JA /= MYSETW) THEN + CALL SET2PE(ISND,0,0,JA,MYSETV) + ISND=NPRCIDS(ISND) + ITAG=1 + CALL MPL_SEND(ZSPU(1:2*KFIELD),KDEST=ISND,KTAG=ITAG, & + & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JA),CDSTRING='EUVTVD_COMM:') + ENDIF + ENDDO + DO JA=1,NPRTRW + IF (JA /= MYSETW) THEN + CALL MPL_WAIT(KREQUEST=ISENDREQ(JA),CDSTRING='EUVTVD_COMM:') + ENDIF + ENDDO +ELSE + CALL SET2PE(ISND,0,0,D%NPROCM(0),MYSETV) + ITAG=1 + CALL MPL_RECV(ZSPU(1:2*KFIELD),KSOURCE=NPRCIDS(ISND),KTAG=ITAG,KOUNT=ILEN, CDSTRING='EUVTVD_COMM:') + IF (ILEN /= 2*KFIELD) CALL ABORT_TRANS('EUVTVD_COMM: RECV INVALID RECEIVE MESSAGE LENGHT') + IF (PRESENT(KFLDPTR)) THEN + DO J=1,KFIELD + IFLD=KFLDPTR(J) + PSPMEANU(IFLD)=ZSPU(J) + PSPMEANV(IFLD)=ZSPU(KFIELD+J) + ENDDO + ELSE + DO J=1,KFIELD + PSPMEANU(J)=ZSPU(J) + PSPMEANV(J)=ZSPU(KFIELD+J) + ENDDO + ENDIF +ENDIF + +IF (LHOOK) CALL DR_HOOK('EUVTVD_COMM_MOD:EUVTVD_COMM',1,ZHOOK_HANDLE) + +END SUBROUTINE EUVTVD_COMM +END MODULE EUVTVD_COMM_MOD diff --git a/src/etrans/etrans/internal/euvtvd_mod.F90 b/src/etrans/etrans/internal/euvtvd_mod.F90 new file mode 100644 index 000000000..38d918d16 --- /dev/null +++ b/src/etrans/etrans/internal/euvtvd_mod.F90 @@ -0,0 +1,111 @@ +MODULE EUVTVD_MOD +CONTAINS +SUBROUTINE EUVTVD(KM,KMLOC,KFIELD,PU,PV,PVOR,PDIV) + +!**** *EUVTVD* - Compute vor/div from u and v in spectral space + +! Purpose. +! -------- +! To compute vorticity and divergence from u and v in spectral +! space. Input u and v from KM to NTMAX+1, output vorticity and +! divergence from KM to NTMAX - calculation part. + +!** Interface. +! ---------- +! CALL EUVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) + +! Explicit arguments : KM - zonal wave-number +! -------------------- KFIELD - number of fields (levels) +! PEPSNM - REPSNM for wavenumber KM +! PU - u wind component for zonal +! wavenumber KM +! PV - v wind component for zonal +! wavenumber KM +! PVOR - vorticity for zonal +! wavenumber KM +! PDIV - divergence for zonal +! wavenumber KM + +! Method. See ref. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 91-07-01 +! D. Giard : NTMAX instead of NSMAX +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! 03-03-03 : G. Radnoti: b-level conform mean-wind distribution +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPMALD_GEO ,ONLY : GALD +USE TPMALD_DISTR ,ONLY : DALD + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM +INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC +INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD +REAL(KIND=JPRB), INTENT(IN) :: PU(:,:) +REAL(KIND=JPRB), INTENT(IN) :: PV(:,:) +REAL(KIND=JPRB), INTENT(OUT):: PVOR(:,:) +REAL(KIND=JPRB), INTENT(OUT):: PDIV(:,:) + +INTEGER(KIND=JPIM) :: II, IN, IR, J, JN + +REAL(KIND=JPRB) :: ZKM, ZIN + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EUVTVD_MOD:EUVTVD',0,ZHOOK_HANDLE) + +!* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. +! ------------------------------------------ + +ZKM=REAL(KM,JPRB)*GALD%EXWN +DO J=1,KFIELD + IR=2*J-1 + II=IR+1 + DO JN=1,R%NDGL+R%NNOEXTZG + PDIV(JN,IR)=-ZKM*PU(JN,II) + PDIV(JN,II)= ZKM*PU(JN,IR) + PVOR(JN,IR)=-ZKM*PV(JN,II) + PVOR(JN,II)= ZKM*PV(JN,IR) + ENDDO +ENDDO +DO J=1,2*KFIELD + DO JN=1,DALD%NCPL2M(KM),2 + IN=(JN-1)/2 + ZIN=REAL(IN,JPRB)*GALD%EYWN + PVOR(JN,J )=PVOR(JN ,J)+ZIN*PU(JN+1,J) + PVOR(JN+1,J)=PVOR(JN+1,J)-ZIN*PU(JN ,J) + PDIV(JN,J )=PDIV(JN ,J)-ZIN*PV(JN+1,J) + PDIV(JN+1,J)=PDIV(JN+1,J)+ZIN*PV(JN ,J) + ENDDO +ENDDO + +IF (LHOOK) CALL DR_HOOK('EUVTVD_MOD:EUVTVD',1,ZHOOK_HANDLE) + +END SUBROUTINE EUVTVD +END MODULE EUVTVD_MOD diff --git a/src/etrans/etrans/internal/euvtvdad_mod.F90 b/src/etrans/etrans/internal/euvtvdad_mod.F90 new file mode 100644 index 000000000..8b72f9932 --- /dev/null +++ b/src/etrans/etrans/internal/euvtvdad_mod.F90 @@ -0,0 +1,128 @@ +MODULE EUVTVDAD_MOD +CONTAINS +SUBROUTINE EUVTVDAD(KM,KMLOC,KFIELD,KFLDPTR,PU,PV,PVOR,PDIV,PSPMEANU,PSPMEANV) + +!**** *EUVTVDAD* - Compute vor/div from u and v in spectral space + +! Purpose. +! -------- +! To compute vorticity and divergence from u and v in spectral +! space. Input u and v from KM to NTMAX+1, output vorticity and +! divergence from KM to NTMAX. + +!** Interface. +! ---------- +! CALL EUVTVDAD() + +! Explicit arguments : KM - zonal wave-number +! -------------------- KFIELD - number of fields (levels) +! KFLDPTR - fields pointers +! PEPSNM - REPSNM for wavenumber KM +! PU - u wind component for zonal +! wavenumber KM +! PV - v wind component for zonal +! wavenumber KM +! PVOR - vorticity for zonal +! wavenumber KM +! PDIV - divergence for zonal +! wavenumber KM + +! Method. See ref. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 91-07-01 +! D. Giard : NTMAX instead of NSMAX +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! 03-03-03 G. Radnoti: b-level conform mean wind distribution +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! 01-Dec-2004 A. Deckmyn removed erasing of mean wind +! D. Degrauwe (Feb 2012): Alternative extension zone (E') +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +!USE TPM_FIELDS + +USE TPMALD_GEO ,ONLY : GALD +USE TPMALD_DISTR ,ONLY : DALD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD, KM, KMLOC +REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:),PDIV(:,:) +REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:),PV (:,:) + +INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) +REAL(KIND=JPRB), OPTIONAL, INTENT(INOUT) :: PSPMEANU(:),PSPMEANV(:) + +INTEGER(KIND=JPIM) :: II, IN, IR, J, JN, IFLD + +REAL(KIND=JPRB) :: ZKM +REAL(KIND=JPRB) :: ZIN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EUVTVDAD_MOD:EUVTVDAD',0,ZHOOK_HANDLE) + +IF (KM == 0) THEN + IF (PRESENT(KFLDPTR)) THEN + DO J=1,KFIELD + IR=2*J-1 + IFLD=KFLDPTR(J) + PU(1,IR)=PSPMEANU(IFLD) + PV(1,IR)=PSPMEANV(IFLD) + ENDDO + ELSE + DO J=1,KFIELD + IR=2*J-1 + PU(1,IR)=PSPMEANU(J) + PV(1,IR)=PSPMEANV(J) + ENDDO + ENDIF +ENDIF + +DO J=1,2*KFIELD + DO JN=1,DALD%NCPL2M(KM),2 + IN=(JN-1)/2 + ZIN=REAL(IN,JPRB)*GALD%EYWN + PU(JN+1,J) = PU(JN+1,J) + ZIN * PVOR(JN ,J) + PU(JN ,J) = PU(JN ,J) - ZIN * PVOR(JN+1,J) + PV(JN+1,J) = PV(JN+1,J) - ZIN * PDIV(JN ,J) + PV(JN ,J) = PV(JN ,J) + ZIN * PDIV(JN+1,J) + ENDDO +ENDDO + +ZKM=REAL(KM,JPRB)*GALD%EXWN +DO J=1,KFIELD + IR=2*J-1 + II=IR+1 + DO JN=1,R%NDGL+R%NNOEXTZG + PU(JN,II) = PU(JN,II) - ZKM * PDIV(JN,IR) + PU(JN,IR) = PU(JN,IR) + ZKM * PDIV(JN,II) + PV(JN,II) = PV(JN,II) - ZKM * PVOR(JN,IR) + PV(JN,IR) = PV(JN,IR) + ZKM * PVOR(JN,II) + ENDDO +ENDDO +IF (LHOOK) CALL DR_HOOK('EUVTVDAD_MOD:EUVTVDAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EUVTVDAD +END MODULE EUVTVDAD_MOD diff --git a/src/etrans/etrans/internal/evdtuv_mod.F90 b/src/etrans/etrans/internal/evdtuv_mod.F90 new file mode 100644 index 000000000..33f9f4e8b --- /dev/null +++ b/src/etrans/etrans/internal/evdtuv_mod.F90 @@ -0,0 +1,125 @@ +MODULE EVDTUV_MOD +CONTAINS +SUBROUTINE EVDTUV(KM,KFIELD,KFLDPTR,PVOR,PDIV,PU,PV,PSPMEANU,PSPMEANV) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DIM +!USE TPM_FIELDS +USE TPMALD_FIELDS ,ONLY : FALD +USE TPMALD_GEO ,ONLY : GALD +USE TPMALD_DISTR ,ONLY : DALD + +!**** *VDTUV* - Compute U,V in spectral space + +! Purpose. +! -------- +! In Laplace space compute the the winds +! from vorticity and divergence. + +!** Interface. +! ---------- +! CALL VDTUV(...) + +! Explicit arguments : KM -zonal wavenumber (input-c) +! -------------------- KFIELD - number of fields (input-c) +! KFLDPTR - fields pointers +! PEPSNM - REPSNM for wavenumber KM (input-c) +! PVOR(NLEI1,2*KFIELD) - vorticity (input) +! PDIV(NLEI1,2*KFIELD) - divergence (input) +! PU(NLEI1,2*KFIELD) - u wind (output) +! PV(NLEI1,2*KFIELD) - v wind (output) +! Organisation within NLEI1: +! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) +! overdimensioning +! 1 : n=NSMAX+2 +! 2 : n=NSMAX+1 +! 3 : n=NSMAX +! . : +! . : +! NSMAX+3 : n=0 +! NSMAX+4 : n=-1 + +! Implicit arguments : Eigenvalues of inverse Laplace operator +! -------------------- from YOMLAP + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS +! Temperton, 1991, MWR 119 p1303 + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From VDTUV in IFS CY22R1 +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM, KFIELD +REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:),PDIV(:,:) +REAL(KIND=JPRB), INTENT(OUT) :: PU (:,:),PV (:,:) + +INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) +REAL(KIND=JPRB), OPTIONAL, INTENT(IN) :: PSPMEANU(:),PSPMEANV(:) + +INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, IN, IFLD + +REAL(KIND=JPRB) :: ZKM +REAL(KIND=JPRB) :: ZIN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +IF (LHOOK) CALL DR_HOOK('EVDTUV_MOD:EVDTUV',0,ZHOOK_HANDLE) +ZKM=REAL(KM,JPRB)*GALD%EXWN +DO J=1,2*KFIELD + DO JN=1,DALD%NCPL2M(KM),2 + IN = (JN-1)/2 + ZIN = REAL(IN,JPRB)*GALD%EYWN + PU(JN ,J) = -ZIN*PVOR(JN+1,J) + PU(JN+1,J) = ZIN*PVOR(JN,J) + PV(JN ,J) = -ZIN*PDIV(JN+1,J) + PV(JN+1,J) = ZIN*PDIV(JN,J) + ENDDO +ENDDO +DO J=1,KFIELD + IR = 2*J-1 + II = IR+1 + DO JN=1,DALD%NCPL2M(KM) + IJ=(JN-1)/2 + PU(JN,IR)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*(-ZKM*PDIV(JN,II)-PU(JN,IR)) + PU(JN,II)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*( ZKM*PDIV(JN,IR)-PU(JN,II)) + PV(JN,IR)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*(-ZKM*PVOR(JN,II)+PV(JN,IR)) + PV(JN,II)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*( ZKM*PVOR(JN,IR)+PV(JN,II)) + ENDDO +ENDDO +IF (KM == 0) THEN + IF (PRESENT(KFLDPTR)) THEN + DO J = 1, KFIELD + IR = 2*J-1 + IFLD=KFLDPTR(J) + PU(1,IR)=PSPMEANU(IFLD) + PV(1,IR)=PSPMEANV(IFLD) + ENDDO + ELSE + DO J = 1, KFIELD + IR = 2*J-1 + PU(1,IR)=PSPMEANU(J) + PV(1,IR)=PSPMEANV(J) + ENDDO + ENDIF +ENDIF +IF (LHOOK) CALL DR_HOOK('EVDTUV_MOD:EVDTUV',1,ZHOOK_HANDLE) + +END SUBROUTINE EVDTUV +END MODULE EVDTUV_MOD diff --git a/src/etrans/etrans/internal/evdtuvad_comm_mod.F90 b/src/etrans/etrans/internal/evdtuvad_comm_mod.F90 new file mode 100644 index 000000000..492a01bbc --- /dev/null +++ b/src/etrans/etrans/internal/evdtuvad_comm_mod.F90 @@ -0,0 +1,163 @@ +MODULE EVDTUVAD_COMM_MOD +CONTAINS +SUBROUTINE EVDTUVAD_COMM(KM,KMLOC,KFIELD,KFLDPTR,PSPMEANU,PSPMEANV) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM +USE TPM_FIELDS +USE TPM_DISTR + +USE TPMALD_FIELDS +USE TPMALD_GEO +USE TPMALD_DISTR + +USE MPL_MODULE +USE ABORT_TRANS_MOD +USE SET2PE_MOD + + +!**** *EVDTUVAD_COMM* - Compute U,V in spectral space + +! Purpose. +! -------- +! In Laplace space communicate the mean winds +! from vorticity and divergence. + +!** Interface. +! ---------- +! CALL EVDTUVAD_COMM(...) + +! Explicit arguments : KM -zonal wavenumber (input-c) +! -------------------- KFIELD - number of fields (input-c) +! KFLDPTR - fields pointers +! PEPSNM - REPSNM for wavenumber KM (input-c) +! Organisation within NLEI1: +! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) +! overdimensioning +! 1 : n=NSMAX+2 +! 2 : n=NSMAX+1 +! 3 : n=NSMAX +! . : +! . : +! NSMAX+3 : n=0 +! NSMAX+4 : n=-1 + +! Implicit arguments : Eigenvalues of inverse Laplace operator +! -------------------- from YOMLAP + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS +! Temperton, 1991, MWR 119 p1303 + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From VDTUVAD in IFS CY22R1 +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! 01-Dec-2004 A. Deckmyn Fix mean wind for NPRTRW > 1 +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + +! thread-safety +! R. El Khatib 12-Jan-2020 Fix missing finalization of communications +! R. El Khatib 02-Jun-2022 Optimization/Cleaning +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM, KFIELD, KMLOC + +INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) +REAL(KIND=JPRB), OPTIONAL, INTENT(OUT) :: PSPMEANU(:),PSPMEANV(:) + +INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, IFLD + +INTEGER(KIND=JPIM) :: IN +INTEGER(KIND=JPIM) :: ISND, JA, ITAG, ILEN + +INTEGER(KIND=JPIM) :: ISENDREQ(NPRTRW) + +REAL(KIND=JPRB) :: ZSPU(2*KFIELD) +REAL(KIND=JPRB) :: ZKM +REAL(KIND=JPRB) :: ZIN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EVDTUVAD_COMM_MOD:EVDTUVAD_COMM',0,ZHOOK_HANDLE) + +IF (NPRTRW > 1 .AND. KFIELD > 0) THEN + IF (KM == 0) THEN + IF (PRESENT(KFLDPTR)) THEN + DO J=1,KFIELD + IFLD=KFLDPTR(J) + ZSPU(J)=PSPMEANU(IFLD) + ZSPU(KFIELD+J)=PSPMEANV(IFLD) + ENDDO + ELSE + DO J=1,KFIELD + ZSPU(J)=PSPMEANU(J) + ZSPU(KFIELD+J)=PSPMEANV(J) + ENDDO + ENDIF + DO JA=1,NPRTRW + IF (JA /= MYSETW) THEN + CALL SET2PE(ISND,0,0,JA,MYSETV) + ISND=NPRCIDS(ISND) + ITAG=300000+KFIELD*NPROC+ISND + CALL MPL_SEND(ZSPU(1:2*KFIELD),KDEST=ISND,KTAG=ITAG, & + & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JA), & + & CDSTRING='EVDTUVAD_COMM:') + ENDIF + ENDDO + ELSE + IF (KMLOC == 1) THEN + IF (D%NPROCM(0) /= MYSETW) THEN + CALL SET2PE(ISND,0,0,D%NPROCM(0),MYSETV) + ISND=NPRCIDS(ISND) + ITAG=300000+KFIELD*NPROC+MYPROC + CALL MPL_RECV(ZSPU(1:2*KFIELD),KSOURCE=ISND,KTAG=ITAG,KOUNT=ILEN,CDSTRING='EVDTUVAD_COMM:') + IF (ILEN /= 2*KFIELD) THEN + CALL ABORT_TRANS('EVDTUVAD_COMM: RECV INVALID RECEIVE MESSAGE LENGTH') + ENDIF + IF (PRESENT(KFLDPTR)) THEN + DO J=1,KFIELD + IFLD=KFLDPTR(J) + PSPMEANU(IFLD)=ZSPU(J) + PSPMEANV(IFLD)=ZSPU(KFIELD+J) + ENDDO + ELSE + DO J=1,KFIELD + PSPMEANU(J)=ZSPU(J) + PSPMEANV(J)=ZSPU(KFIELD+J) + ENDDO + ENDIF + ENDIF + ENDIF + ENDIF + IF (KM == 0) THEN + DO JA=1,NPRTRW + IF (JA /= MYSETW) THEN + CALL MPL_WAIT(KREQUEST=ISENDREQ(JA),CDSTRING='EUVTVDAD_COMM:') + ENDIF + ENDDO + ENDIF +ENDIF + +IF (LHOOK) CALL DR_HOOK('EVDTUVAD_COMM_MOD:EVDTUVAD_COMM',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EVDTUVAD_COMM +END MODULE EVDTUVAD_COMM_MOD diff --git a/src/etrans/etrans/internal/evdtuvad_mod.F90 b/src/etrans/etrans/internal/evdtuvad_mod.F90 new file mode 100644 index 000000000..a34135fcb --- /dev/null +++ b/src/etrans/etrans/internal/evdtuvad_mod.F90 @@ -0,0 +1,151 @@ +MODULE EVDTUVAD_MOD +CONTAINS +SUBROUTINE EVDTUVAD(KM,KMLOC,KFIELD,KFLDPTR,PVOR,PDIV,PU,PV,PSPMEANU,PSPMEANV) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +!USE TPM_DIM +!USE TPM_FIELDS +USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC + +USE TPMALD_FIELDS ,ONLY : FALD +USE TPMALD_GEO ,ONLY : GALD +USE TPMALD_DISTR ,ONLY : DALD + +!**** *EVDTUVAD* - Compute U,V in spectral space + +! Purpose. +! -------- +! In Laplace space compute the the winds +! from vorticity and divergence. + +!** Interface. +! ---------- +! CALL EVDTUVAD(...) + +! Explicit arguments : KM -zonal wavenumber (input-c) +! -------------------- KFIELD - number of fields (input-c) +! KFLDPTR - fields pointers +! PEPSNM - REPSNM for wavenumber KM (input-c) +! PVOR(NLEI1,2*KFIELD) - vorticity (input) +! PDIV(NLEI1,2*KFIELD) - divergence (input) +! PU(NLEI1,2*KFIELD) - u wind (output) +! PV(NLEI1,2*KFIELD) - v wind (output) +! Organisation within NLEI1: +! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) +! overdimensioning +! 1 : n=NSMAX+2 +! 2 : n=NSMAX+1 +! 3 : n=NSMAX +! . : +! . : +! NSMAX+3 : n=0 +! NSMAX+4 : n=-1 + +! Implicit arguments : Eigenvalues of inverse Laplace operator +! -------------------- from YOMLAP + +! Method. +! ------- + +! Externals. None. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS +! Temperton, 1991, MWR 119 p1303 + +! Author. +! ------- +! Mats Hamrud and Philippe Courtier *ECMWF* + +! Modifications. +! -------------- +! Original : 00-02-01 From VDTUVAD in IFS CY22R1 +! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! 01-Dec-2004 A. Deckmyn Fix mean wind for NPRTRW > 1 +! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + +! thread-safety +! ------------------------------------------------------------------ + +IMPLICIT NONE + +INTEGER(KIND=JPIM), INTENT(IN) :: KM, KFIELD, KMLOC +REAL(KIND=JPRB), INTENT(INOUT) :: PVOR(:,:),PDIV(:,:) +REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:),PV (:,:) + +INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) +REAL(KIND=JPRB), OPTIONAL, INTENT(OUT) :: PSPMEANU(:),PSPMEANV(:) + +INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, IFLD + +INTEGER(KIND=JPIM) :: IN +INTEGER(KIND=JPIM) :: ISND, JA, ITAG, ILEN + +REAL(KIND=JPRB) :: ZSPU(2*KFIELD) +REAL(KIND=JPRB) :: ZKM +REAL(KIND=JPRB) :: ZIN +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('EVDTUVAD_MOD:EVDTUVAD',0,ZHOOK_HANDLE) + +IF (KM == 0) THEN + IF (PRESENT(KFLDPTR)) THEN + DO J = 1, KFIELD + IR = 2*J-1 + IFLD=KFLDPTR(J) + PSPMEANU(IFLD)=PU(1,IR) + PSPMEANV(IFLD)=PV(1,IR) + ENDDO + ELSE + DO J = 1, KFIELD + IR = 2*J-1 + PSPMEANU(J)=PU(1,IR) + PSPMEANV(J)=PV(1,IR) + ENDDO + ENDIF +ENDIF + +ZKM=REAL(KM,JPRB)*GALD%EXWN +DO J=1,KFIELD + IR = 2*J-1 + II = IR+1 + DO JN=1,DALD%NCPL2M(KM) + IJ=(JN-1)/2 + PDIV(JN,II)=PDIV(JN,II)-ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,IR) + PU(JN,IR)=-FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,IR) + + PDIV(JN,IR)=PDIV(JN,IR)+ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,II) + PU(JN,II)=-FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,II) + + PVOR(JN,II)=PVOR(JN,II)-ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,IR) + PV(JN,IR)=FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,IR) + + PVOR(JN,IR)=PVOR(JN,IR)+ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,II) + PV(JN,II)=FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,II) + + ENDDO +ENDDO + +DO J=1,2*KFIELD + DO JN=1,DALD%NCPL2M(KM),2 + IN = (JN-1)/2 + ZIN = REAL(IN,JPRB)*GALD%EYWN + PVOR(JN+1,J) = PVOR(JN+1,J)-ZIN*PU(JN ,J) + PVOR(JN ,J) = PVOR(JN ,J)+ZIN*PU(JN+1,J) + PDIV(JN+1,J) = PDIV(JN+1,J)-ZIN*PV(JN ,J) + PDIV(JN ,J) = PDIV(JN ,J)+ZIN*PV(JN+1,J) + ENDDO +ENDDO + +IF (LHOOK) CALL DR_HOOK('EVDTUVAD_MOD:EVDTUVAD',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE EVDTUVAD +END MODULE EVDTUVAD_MOD diff --git a/src/etrans/etrans/internal/suefft_mod.F90 b/src/etrans/etrans/internal/suefft_mod.F90 new file mode 100644 index 000000000..96d48790f --- /dev/null +++ b/src/etrans/etrans/internal/suefft_mod.F90 @@ -0,0 +1,114 @@ +MODULE SUEFFT_MOD +CONTAINS +SUBROUTINE SUEFFT + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_DIM ,ONLY : R +USE TPM_GEN ,ONLY : NOUT, NPRINTLEV +USE TPM_DISTR ,ONLY : D, MYSETW +USE TPM_GEOMETRY ,ONLY : G +USE TPM_FFT ,ONLY : T, TB +#ifdef WITH_FFTW +USE TPM_FFTW ,ONLY : TW, INIT_PLANS_FFTW +#endif +USE BLUESTEIN_MOD ,ONLY : BLUESTEIN_INIT, FFTB_TYPE +! + +USE TPMALD_FFT ,ONLY : TALD +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: JGL,IGLG, ILATS +LOGICAL :: LLP1,LLP2 +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('SUEFFT_MOD:SUEFFT',0,ZHOOK_HANDLE) + +IF(.NOT.D%LGRIDONLY) THEN + + LLP1 = NPRINTLEV>0 + LLP2 = NPRINTLEV>1 + IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEFFT ===' + +#ifdef WITH_FFTW + IF(TW%LFFTW)THEN + + CALL INIT_PLANS_FFTW(MAX(R%NDLON+R%NNOEXTZL,R%NDGL+R%NNOEXTZG)) + + ELSE + + NULLIFY(TW%FFTW_PLANS) +#endif + + ALLOCATE(T%TRIGS(R%NDLON+R%NNOEXTZL,D%NDGL_FS)) + IF(LLP2)WRITE(NOUT,9) 'T%TRIGS ',SIZE(T%TRIGS),SHAPE(T%TRIGS) + ALLOCATE(T%NFAX(19,D%NDGL_FS)) + IF(LLP2)WRITE(NOUT,9) 'T%NFAX ',SIZE(T%NFAX),SHAPE(T%NFAX) + ALLOCATE(T%LUSEFFT992(D%NDGL_FS)) + IF(LLP2)WRITE(NOUT,9) 'T%LUSEFFT992',SIZE(T%LUSEFFT992),SHAPE(T%LUSEFFT992) + + ! + ! create TRIGS and NFAX for latitude lengths supported by FFT992, + ! that is just with factors 2, 3 or 5 + ! + + T%LBLUESTEIN=.FALSE. + ILATS=0 + DO JGL=1,D%NDGL_FS + IGLG = D%NPTRLS(MYSETW)+JGL-1 + IF (G%NLOEN(IGLG)>1) THEN + CALL SET99B(T%TRIGS(1,JGL),T%NFAX(1,JGL),G%NLOEN(IGLG)+R%NNOEXTZL,T%LUSEFFT992(JGL)) + IF( .NOT.T%LUSEFFT992(JGL) )THEN + ILATS=ILATS+1 + T%LBLUESTEIN=.TRUE. + ENDIF + ENDIF + ENDDO + + ! + ! we only initialise for bluestein if there are latitude lengths + ! not supported by FFT992 + ! + + IF( T%LBLUESTEIN )THEN + TB%NDLON=R%NDLON + TB%NLAT_COUNT=ILATS + ILATS=0 + ALLOCATE(TB%NLATS(TB%NLAT_COUNT)) + DO JGL=1,D%NDGL_FS + IF( .NOT.T%LUSEFFT992(JGL) )THEN + ILATS=ILATS+1 + TB%NLATS(ILATS)=R%NDLON+R%NNOEXTZL + ENDIF + ENDDO + CALL BLUESTEIN_INIT(TB) + ENDIF + +#ifdef WITH_FFTW + + ENDIF +#endif + + IF(TALD%LFFT992)THEN + ALLOCATE(TALD%TRIGSE(R%NDGL+R%NNOEXTZG)) + IF(LLP2)WRITE(NOUT,9) 'TALD%TRIGSE ',SIZE(TALD%TRIGSE),SHAPE(TALD%TRIGSE) + ALLOCATE(TALD%NFAXE(19)) + IF(LLP2)WRITE(NOUT,9) 'TALD%NFAXE ',SIZE(TALD%NFAXE),SHAPE(TALD%NFAXE) + CALL SET99(TALD%TRIGSE,TALD%NFAXE,R%NDGL+R%NNOEXTZG) + ENDIF + +ENDIF + +IF (LHOOK) CALL DR_HOOK('SUEFFT_MOD:SUEFFT',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) + +END SUBROUTINE SUEFFT +END MODULE SUEFFT_MOD diff --git a/src/etrans/etrans/internal/suemp_trans_mod.F90 b/src/etrans/etrans/internal/suemp_trans_mod.F90 new file mode 100644 index 000000000..ae689f5e1 --- /dev/null +++ b/src/etrans/etrans/internal/suemp_trans_mod.F90 @@ -0,0 +1,267 @@ +MODULE SUEMP_TRANS_MOD +CONTAINS +SUBROUTINE SUEMP_TRANS + +! Set up distributed environment for the transform package (part 2) +! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NOUT, NPRINTLEV +USE TPM_DIM ,ONLY : R +USE TPM_GEOMETRY ,ONLY : G +USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, NPRTRNS, NPRTRV, NPRTRW, MYSETW, NPROC, MYPROC +USE TPMALD_DIM ,ONLY : RALD +!USE TPMALD_DISTR +!USE SUWAVEDI_MOD +!USE PE2SET_MOD +USE SUMPLATF_MOD ,ONLY : SUMPLATF +USE SUEMPLAT_MOD ,ONLY : SUEMPLAT +USE SUESTAONL_MOD ,ONLY : SUESTAONL +USE MYSENDSET_MOD ,ONLY : MYSENDSET +USE MYRECVSET_MOD ,ONLY : MYRECVSET +USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & + & N_REGIONS, N_REGIONS_EW, N_REGIONS_NS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: JM,JMLOC +INTEGER(KIND=JPIM) :: JGL,IGL,IPLAT,ISENDSET,IRECVSET,JML,IPOS,IM +INTEGER(KIND=JPIM) :: I1,I2,I3,IAUX0,IAUX1,JA1 +INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF +INTEGER(KIND=JPIM), ALLOCATABLE :: IGPTOTL(:,:) + +REAL(KIND=JPRB) :: ZMEDIAP + +LOGICAL :: LLP1,LLP2 +REAL(KIND=JPRB),ALLOCATABLE :: ZDUM(:) +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ------------------------------------------------------------------ + +IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_MOD:SUEMP_TRANS',0,ZHOOK_HANDLE) +LLP1 = NPRINTLEV>0 +LLP2 = NPRINTLEV>1 +IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEMP_TRANS ===' + +IF(.NOT.D%LGRIDONLY) THEN + +ALLOCATE(D%NULTPP(NPRTRNS)) +IF(LLP2)WRITE(NOUT,9) 'D%NULTPP ',SIZE(D%NULTPP ),SHAPE(D%NULTPP ) +ALLOCATE(D%NPTRLS(NPRTRNS)) +IF(LLP2)WRITE(NOUT,9) 'D%NPTRLS ',SIZE(D%NPTRLS ),SHAPE(D%NPTRLS ) +ALLOCATE(D%NPROCL(R%NDGL)) +IF(LLP2)WRITE(NOUT,9) 'D%NPROCL ',SIZE(D%NPROCL ),SHAPE(D%NPROCL ) + +CALL SUMPLATF(R%NDGL,NPRTRNS,MYSETW,D%NULTPP,D%NPROCL,D%NPTRLS) +D%NDGL_FS = D%NULTPP(MYSETW) + +! Help arrays for spectral to fourier space transposition +ALLOCATE(D%NLTSGTB (NPRTRNS+1)) +IF(LLP2)WRITE(NOUT,9) 'D%NLTSGTB ',SIZE(D%NLTSGTB),SHAPE(D%NLTSGTB) +ALLOCATE(D%NLTSFTB (NPRTRNS+1)) +IF(LLP2)WRITE(NOUT,9) 'D%NLTSFTB ',SIZE(D%NLTSFTB),SHAPE(D%NLTSFTB) +ALLOCATE(D%NSTAGT0B(NPRTRNS+1)) +IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT0B ',SIZE(D%NSTAGT0B),SHAPE(D%NSTAGT0B) +ALLOCATE(D%NSTAGT1B(NPRTRNS+1)) +IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT1B ',SIZE(D%NSTAGT1B),SHAPE(D%NSTAGT1B) +ALLOCATE(D%MSTABF (NPRTRNS+1)) +IF(LLP2)WRITE(NOUT,9) 'D%MSTABF ',SIZE(D%MSTABF),SHAPE(D%MSTABF) + +D%NLTSGTB(:) = 0 +DO JGL=1,D%NDGL_FS + IGL = D%NPTRLS(MYSETW)+JGL-1 + DO JM=0,G%NMEN(IGL) + D%NLTSGTB(D%NPROCM(JM)) = D%NLTSGTB(D%NPROCM(JM))+1 + ENDDO +ENDDO +DO JA=1,NPRTRW + IPLAT = 0 + DO JGL=1,D%NULTPP(JA) + IGL = D%NPTRLS(JA)+JGL-1 + DO JM=1,D%NUMP + IF(IGL > R%NDGNH-G%NDGLU(D%MYMS(JM)) .AND. IGL <= R%NDGNH+G%NDGLU(D%MYMS(JM))) THEN + IPLAT = IPLAT + 1 + ENDIF + ENDDO + ENDDO + D%NLTSFTB(JA) = IPLAT +ENDDO + +DO JA=1,NPRTRW-1 + ISENDSET = MYSENDSET(NPRTRW,MYSETW,JA) + IRECVSET = MYRECVSET(NPRTRW,MYSETW,JA) + D%MSTABF(IRECVSET) = ISENDSET +ENDDO +D%MSTABF(MYSETW) = MYSETW + +ALLOCATE(D%NPNTGTB0(0:RALD%NMSMAX,D%NDGL_FS)) +IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB0 ',SIZE(D%NPNTGTB0 ),SHAPE(D%NPNTGTB0 ) +ALLOCATE(D%NPNTGTB1(D%NUMP,R%NDGL)) +IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB1 ',SIZE(D%NPNTGTB1 ),SHAPE(D%NPNTGTB1 ) + +DO JA=1,NPRTRW + IPOS = 0 + DO JGL=1,D%NULTPP(MYSETW) + IGL = D%NPTRLS(MYSETW) + JGL - 1 + DO JML=D%NPTRMS(JA),D%NPTRMS(JA)+D%NUMPP(JA)-1 + IM = D%NALLMS(JML) + IF (IM <= G%NMEN(IGL)) THEN + D%NPNTGTB0(IM,JGL) = IPOS + IPOS = IPOS+1 + ELSE + D%NPNTGTB0(IM,JGL) = -99 + ENDIF + ENDDO + ENDDO +ENDDO + +DO JA=1,NPRTRW + IPOS = 0 + DO JGL=1,D%NULTPP(JA) + IGL = D%NPTRLS(JA) + JGL - 1 + DO JM=1,D%NUMP + IM = D%MYMS(JM) + IF (IM <= G%NMEN(IGL)) THEN + D%NPNTGTB1(JM,IGL) = IPOS + IPOS = IPOS+1 + ELSE + D%NPNTGTB1(JM,IGL) = -99 + ENDIF + ENDDO + ENDDO +ENDDO + +IAUX0 = 0 +IAUX1 = 0 +DO JA=1,NPRTRNS-1 + I1 = MYSENDSET(NPRTRNS,MYSETW,JA) + I2 = MYRECVSET(NPRTRNS,MYSETW,JA) + DO JA1=1,NPRTRNS-1 + IF(MYSENDSET(NPRTRNS,MYSETW,JA1) == I2) I3 =MYRECVSET(NPRTRNS,MYSETW,JA1) + ENDDO + IAUX0 = MAX(D%NLTSFTB(I1),D%NLTSGTB(I2),IAUX0) + IAUX1 = MAX(D%NLTSGTB(I2),D%NLTSFTB(I3),IAUX1) +ENDDO +IAUX0 = MAX(D%NLTSGTB(MYSETW),IAUX0) +IAUX1 = MAX(D%NLTSGTB(MYSETW),IAUX1) +DO JA=1,NPRTRNS+1 + D%NSTAGT0B(JA) = (JA-1)*IAUX0 + D%NSTAGT1B(JA) = (JA-1)*IAUX1 +ENDDO +D%NLENGT0B = IAUX0*NPRTRNS +D%NLENGT1B = IAUX1*NPRTRNS + +ENDIF + +! GRIDPOINT SPACE + +ALLOCATE(D%NFRSTLAT(N_REGIONS_NS)) +IF(LLP2)WRITE(NOUT,9) 'D%NFRSTLAT ',SIZE(D%NFRSTLAT ),SHAPE(D%NFRSTLAT ) +ALLOCATE(D%NLSTLAT(N_REGIONS_NS)) +IF(LLP2)WRITE(NOUT,9) 'D%NLSTLAT ',SIZE(D%NLSTLAT ),SHAPE(D%NLSTLAT ) +ALLOCATE(D%NPTRLAT(R%NDGL)) +IF(LLP2)WRITE(NOUT,9) 'D%NPTRLAT ',SIZE(D%NPTRLAT ),SHAPE(D%NPTRLAT ) +ALLOCATE(D%NPTRFRSTLAT(N_REGIONS_NS)) +IF(LLP2)WRITE(NOUT,9) 'D%NPTRFRSTLAT',SIZE(D%NPTRFRSTLAT),SHAPE(D%NPTRFRSTLAT) +ALLOCATE(D%NPTRLSTLAT(N_REGIONS_NS)) +IF(LLP2)WRITE(NOUT,9)'D%NPTRLSTLAT',SIZE(D%NPTRLSTLAT),SHAPE(D%NPTRLSTLAT) +ALLOCATE(D%LSPLITLAT(R%NDGL)) +IF(LLP2)WRITE(NOUT,9) 'D%LSPLITLAT',SIZE(D%LSPLITLAT),SHAPE(D%LSPLITLAT) +ALLOCATE(D%NPROCA_GP(N_REGIONS_NS)) +IF(LLP2)WRITE(NOUT,9) 'D%NPROCA_GP',SIZE(D%NPROCA_GP),SHAPE(D%NPROCA_GP) + + +IF(.NOT.D%LWEIGHTED_DISTR) THEN + ALLOCATE(ZDUM(1)) + CALL SUEMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT, LEQ_REGIONS,& + & D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& + & D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& + & ZDUM,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& + & IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN,RALD%NDGUX) +ELSE + CALL SUEMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT, LEQ_REGIONS,& + & D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& + & D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& + & D%RWEIGHT,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& + & IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN,RALD%NDGUX) +ENDIF +D%NDGL_GP = D%NLSTLAT(MY_REGION_NS)-D%NFRSTLOFF + +IF (LLP1) THEN + IF(.NOT.D%LGRIDONLY) THEN + WRITE(NOUT,FMT='(/'' OUTPUT FROM ROUTINE SUEMPLAT: ''/)') + WRITE(NOUT,FMT='('' D%NULTPP '')') + WRITE(NOUT,FMT='(20(1X,I4))') D%NULTPP(1:NPRTRNS) + WRITE(NOUT,FMT='('' D%NPROCL '')') + WRITE(NOUT,FMT='(20(1X,I4))') D%NPROCL(1:R%NDGL) + ENDIF + WRITE(NOUT,FMT='('' D%NFRSTLAT '')') + WRITE(NOUT,FMT='(20(1X,I4))') D%NFRSTLAT(1:N_REGIONS_NS) + WRITE(NOUT,FMT='('' D%NLSTLAT '')') + WRITE(NOUT,FMT='(20(1X,I4))') D%NLSTLAT(1:N_REGIONS_NS) + WRITE(NOUT,FMT='('' D%NFRSTLOFF D%NPTRFLOFF '')') + WRITE(NOUT,FMT='(2(1X,I6))') D%NFRSTLOFF, D%NPTRFLOFF + WRITE(NOUT,FMT='('' D%NPTRLAT '')') + WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLAT(1:R%NDGL) + WRITE(NOUT,FMT='('' D%LSPLITLAT '')') + WRITE(NOUT,FMT='(50(1X,L1))') D%LSPLITLAT(1:R%NDGL) + WRITE(NOUT,FMT='('' D%NPTRFRSTLAT '')') + WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRFRSTLAT(1:N_REGIONS_NS) + WRITE(NOUT,FMT='('' D%NPTRLSTLAT '')') + WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLSTLAT(1:N_REGIONS_NS) + WRITE(NOUT,FMT='(/)') +ENDIF +ALLOCATE(D%NSTA(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) +IF(LLP2)WRITE(NOUT,9) 'D%NSTA ',SIZE(D%NSTA ),SHAPE(D%NSTA ) +ALLOCATE(D%NONL(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) +IF(LLP2)WRITE(NOUT,9) 'D%NONL ',SIZE(D%NONL ),SHAPE(D%NONL ) + +IF(.NOT.D%LWEIGHTED_DISTR) THEN + CALL SUESTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,ZDUM,ZMEDIAP,D%NPROCA_GP) +ELSE + CALL SUESTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,D%RWEIGHT,ZMEDIAP,D%NPROCA_GP) +ENDIF +! IGPTOTL is the number of grid points in each individual processor +ALLOCATE(IGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) +IGPTOTL(:,:)=0 +DO JA=1,N_REGIONS_NS + DO JB=1,N_REGIONS(JA) + IGPTOT = 0 + DO JGL=D%NPTRFRSTLAT(JA),D%NPTRLSTLAT(JA) + IGPTOT = IGPTOT+D%NONL(JGL,JB) + ENDDO + IGPTOTL(JA,JB) = IGPTOT + ENDDO +ENDDO +D%NGPTOT = IGPTOTL(MY_REGION_NS,MY_REGION_EW) +D%NGPTOTMX = MAXVAL(IGPTOTL) +D%NGPTOTG = SUM(IGPTOTL) +ALLOCATE(D%NGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) +IF(LLP2)WRITE(NOUT,9) 'D%NGPTOTL ',SIZE(D%NGPTOTL ),SHAPE(D%NGPTOTL ) +D%NGPTOTL(:,:) = IGPTOTL(:,:) + +IF(.NOT.D%LGRIDONLY) THEN +ALLOCATE(D%NSTAGTF(D%NDGL_FS)) +IF(LLP2)WRITE(NOUT,9) 'D%NSTAGTF ',SIZE(D%NSTAGTF ),SHAPE(D%NSTAGTF ) +IOFF = 0 +DO JGL=1,D%NDGL_FS + D%NSTAGTF(JGL) = IOFF + IGL = D%NPTRLS(MYSETW) + JGL - 1 + IOFF = IOFF + G%NLOEN(IGL)+3+R%NNOEXTZL +ENDDO +D%NLENGTF = IOFF +ENDIF + +IF(ALLOCATED(ZDUM)) DEALLOCATE(ZDUM) +DEALLOCATE(IGPTOTL) +IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_MOD:SUEMP_TRANS',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ +9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) + +END SUBROUTINE SUEMP_TRANS +END MODULE SUEMP_TRANS_MOD + diff --git a/src/etrans/etrans/internal/suemp_trans_preleg_mod.F90 b/src/etrans/etrans/internal/suemp_trans_preleg_mod.F90 new file mode 100644 index 000000000..34f3fb7cd --- /dev/null +++ b/src/etrans/etrans/internal/suemp_trans_preleg_mod.F90 @@ -0,0 +1,240 @@ +MODULE SUEMP_TRANS_PRELEG_MOD +CONTAINS +SUBROUTINE SUEMP_TRANS_PRELEG + +! Set up distributed environment for the transform package (part 1) + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NOUT, NPRINTLEV +USE TPM_DIM ,ONLY : R +USE TPM_DISTR ,ONLY : D, NPRTRW, NPRTRV, MYSETW + +USE TPMALD_DISTR ,ONLY : DALD +USE TPMALD_DIM ,ONLY : RALD +USE TPMALD_FIELDS ,ONLY : FALD +USE TPMALD_GEO ,ONLY : GALD + +!USE SUWAVEDI_MOD +!USE ABORT_TRANS_MOD + +IMPLICIT NONE + + INTEGER(KIND=JPIM) :: JA,JM,JMLOC,JW,JV,ILATPP,IRESTL,IMLOC,IDT,INM,JN,IM,ILAST + + LOGICAL :: LLP1,LLP2 + + INTEGER(KIND=JPIM) :: ISPEC(NPRTRW),IMYMS(RALD%NMSMAX+1),IKNTMP(0:RALD%NMSMAX) + INTEGER(KIND=JPIM) :: IKMTMP(0:R%NSMAX),ISPEC2P + INTEGER(KIND=JPIM) :: IC(NPRTRW) + INTEGER(KIND=JPIM) :: IMDIM,IL,IND,IK,IPOS,IKM + REAL(KIND=JPRB) :: ZLEPDIM + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + ! ------------------------------------------------------------------ + + IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_PRELEG_MOD:SUEMP_TRANS_PRELEG',0,ZHOOK_HANDLE) + + IF(.NOT.D%LGRIDONLY) THEN + + LLP1 = NPRINTLEV>0 + LLP2 = NPRINTLEV>1 + IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEMP_TRANS_PRELEG ===' + + !* 1. Initialize partitioning of wave numbers to PEs ! + ! ---------------------------------------------- + + ALLOCATE(D%NASM0(0:R%NSMAX)) + IF(LLP2)WRITE(NOUT,9) 'D%NASM0 ',SIZE(D%NASM0 ),SHAPE(D%NASM0 ) + + ALLOCATE(DALD%NESM0(0:RALD%NMSMAX)) + IF(LLP2)WRITE(NOUT,9) 'DALD%NESM0 ',SIZE(DALD%NESM0 ),SHAPE(DALD%NESM0 ) + + ALLOCATE(D%NATM0(0:R%NTMAX)) + IF(LLP2)WRITE(NOUT,9) 'D%NATM0 ',SIZE(D%NATM0 ),SHAPE(D%NATM0 ) + ALLOCATE(D%NUMPP(NPRTRW)) + IF(LLP2)WRITE(NOUT,9) 'D%NUMPP ',SIZE(D%NUMPP ),SHAPE(D%NUMPP ) + ALLOCATE(D%NPOSSP(NPRTRW+1)) + IF(LLP2)WRITE(NOUT,9) 'D%NPOSSP',SIZE(D%NPOSSP ),SHAPE(D%NPOSSP ) + + ALLOCATE(D%NPROCM(0:RALD%NMSMAX)) + IF(LLP2)WRITE(NOUT,9) 'D%NPROCM',SIZE(D%NPROCM ),SHAPE(D%NPROCM ) + + ALLOCATE(DALD%NPME(0:RALD%NMSMAX)) + IF(LLP2)WRITE(NOUT,9) 'DALD%NPME',SIZE(DALD%NPME),SHAPE(DALD%NPME) + ALLOCATE(DALD%NCPL2M(0:RALD%NMSMAX)) + IF(LLP2)WRITE(NOUT,9) 'DALD%NCPL2M',SIZE(DALD%NCPL2M),SHAPE(DALD%NCPL2M) + CALL ELLIPS(R%NSMAX,RALD%NMSMAX,IKNTMP,IKMTMP) + DALD%NPME(0)=1 + DO JM=1,RALD%NMSMAX + DALD%NPME(JM)=DALD%NPME(JM-1)+IKNTMP(JM-1)+1 + ENDDO + DO JM=0,RALD%NMSMAX + DALD%NCPL2M(JM) = 2*(IKNTMP(JM)+1) + ENDDO + ALLOCATE(FALD%RLEPINM(R%NSPEC_G/2)) + IF(LLP2)WRITE(NOUT,9) 'FALD%RLEPINM',SIZE(FALD%RLEPINM),SHAPE(FALD%RLEPINM) + DO JM=0,RALD%NMSMAX + DO JN=1,IKNTMP(JM) + ZLEPDIM=-((REAL(JM,JPRB)**2)*(GALD%EXWN**2)+& + & (REAL(JN,JPRB)**2)*(GALD%EYWN**2)) + FALD%RLEPINM(DALD%NPME(JM)+JN)=1./ZLEPDIM + ENDDO + ENDDO + DO JM=1,RALD%NMSMAX + ZLEPDIM=-(REAL(JM,JPRB)**2)*(GALD%EXWN**2) + FALD%RLEPINM(DALD%NPME(JM))=1./ZLEPDIM + ENDDO + FALD%RLEPINM(DALD%NPME(0))=0. + + D%NUMPP(:) = 0 + ISPEC(:) = 0 + DALD%NESM0(:)=-99 + + IMDIM = 0 + IL = 1 + IND = 1 + IK = 0 + IPOS = 1 + DO JM=0,RALD%NMSMAX + IK = IK + IND + IF (IK > NPRTRW) THEN + IK = NPRTRW + IND = -1 + ELSEIF (IK < 1) THEN + IK = 1 + IND = 1 + ENDIF + + IKM =DALD%NCPL2M(JM)/2 -1 + D%NPROCM(JM) = IK + ISPEC(IK) = ISPEC(IK)+IKM+1 + D%NUMPP(IK) = D%NUMPP(IK)+1 + IF (IK == MYSETW) THEN + IMDIM = IMDIM + IKM+1 + IMYMS(IL) = JM + DALD%NESM0(JM) = IPOS + IPOS = IPOS+(IKM+1)*4 + IL = IL+1 + ENDIF + ENDDO + D%NPOSSP(1) = 1 + ISPEC2P = 4*ISPEC(1) + D%NSPEC2MX = ISPEC2P + DO JA=2,NPRTRW + D%NPOSSP(JA) = D%NPOSSP(JA-1)+ISPEC2P + ISPEC2P = 4*ISPEC(JA) + D%NSPEC2MX=MAX(D%NSPEC2MX,ISPEC2P) + ENDDO + D%NPOSSP(NPRTRW+1) = D%NPOSSP(NPRTRW)+ISPEC2P + + D%NSPEC2 = 4*IMDIM + D%NSPEC=D%NSPEC2 + + D%NUMP = D%NUMPP (MYSETW) + ALLOCATE(D%MYMS(D%NUMP)) + IF(LLP2)WRITE(NOUT,9) 'D%MYMS ',SIZE(D%MYMS ),SHAPE(D%MYMS ) + D%MYMS(:) = IMYMS(1:D%NUMP) + D%NUMTP = D%NUMP + + ! pointer to the first wave number of a given wave-set in NALLMS array + ALLOCATE(D%NPTRMS(NPRTRW)) + IF(LLP2)WRITE(NOUT,9) 'D%NPTRMS ',SIZE(D%NPTRMS ),SHAPE(D%NPTRMS ) + D%NPTRMS(:) = 1 + DO JA=2,NPRTRW + D%NPTRMS(JA) = D%NPTRMS(JA-1)+D%NUMPP(JA-1) + ENDDO + ! D%NALLMS : wave numbers for all wave-set concatenated together to give all + ! wave numbers in wave-set order. + ALLOCATE(D%NALLMS(RALD%NMSMAX+1)) + IF(LLP2)WRITE(NOUT,9) 'D%NALLMS ',SIZE(D%NALLMS ),SHAPE(D%NALLMS ) + IC(:) = 0 + DO JM=0,RALD%NMSMAX + D%NALLMS(IC(D%NPROCM(JM))+D%NPTRMS(D%NPROCM(JM))) = JM + IC(D%NPROCM(JM)) = IC(D%NPROCM(JM))+1 + ENDDO + ALLOCATE(D%NDIM0G(0:RALD%NMSMAX)) + IF(LLP2)WRITE(NOUT,9) 'D%NDIM0G ',SIZE(D%NDIM0G ),SHAPE(D%NDIM0G ) + IPOS = 1 + DO JA=1,NPRTRW + DO JMLOC=1,D%NUMPP(JA) + IM = D%NALLMS(D%NPTRMS(JA)+JMLOC-1) + D%NDIM0G(IM) = IPOS + IPOS = IPOS+2*DALD%NCPL2M(IM) + ENDDO + ENDDO + +ALLOCATE(D%NLATLS(NPRTRW,NPRTRV)) +IF(LLP2)WRITE(NOUT,9) 'D%NLATLS',SIZE(D%NLATLS ),SHAPE(D%NLATLS ) +ALLOCATE(D%NLATLE(NPRTRW,NPRTRV)) +IF(LLP2)WRITE(NOUT,9) 'D%NLATLE',SIZE(D%NLATLE ),SHAPE(D%NLATLE ) + +D%NLATLS(:,:) = 9999 +D%NLATLE(:,:) = -1 + +ILATPP = R%NDGL/NPRTRW +IRESTL = R%NDGL-NPRTRW*ILATPP +DO JW=1,NPRTRW + IF (JW > IRESTL) THEN + D%NLATLS(JW,1) = IRESTL*(ILATPP+1)+(JA-IRESTL-1)*ILATPP+1 + D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP-1 + ELSE + D%NLATLS(JW,1) = (JA-1)*(ILATPP+1)+1 + D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP + ENDIF +ENDDO +ILAST=0 +DO JW=1,NPRTRW + ILATPP = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)/NPRTRV + IRESTL = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)-NPRTRV*ILATPP + DO JV=1,NPRTRV + IF (JV > IRESTL) THEN + D%NLATLS(JW,JV) = IRESTL*(ILATPP+1)+(JV-IRESTL-1)*ILATPP+1+ILAST + D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP-1 + ELSE + D%NLATLS(JW,JV) = (JV-1)*(ILATPP+1)+1+ILAST + D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP + ENDIF + ENDDO + ILAST=D%NLATLE(JW,NPRTRV) +ENDDO +IF (LLP1) THEN + DO JW=1,NPRTRW + DO JV=1,NPRTRV + WRITE(NOUT,'(" JW=",I6," JV=",I6," D%NLATLS=",I6," D%NLATLE=",I6)')& + & JW,JV,D%NLATLS(JW,JV),D%NLATLE(JW,JV) + ENDDO + ENDDO +ENDIF + +ALLOCATE(D%NPMT(0:R%NSMAX)) +IF(LLP2)WRITE(NOUT,9) 'D%NPMT ',SIZE(D%NPMT ),SHAPE(D%NPMT ) +ALLOCATE(D%NPMS(0:R%NSMAX)) +IF(LLP2)WRITE(NOUT,9) 'D%NPMS ',SIZE(D%NPMS ),SHAPE(D%NPMS ) +ALLOCATE(D%NPMG(0:R%NSMAX)) +IF(LLP2)WRITE(NOUT,9) 'D%NPMG ',SIZE(D%NPMG ),SHAPE(D%NPMG ) +IDT = R%NTMAX-R%NSMAX +INM = 0 +DO JMLOC=1,D%NUMP + IMLOC = D%MYMS(JMLOC) + + INM = INM+R%NTMAX+2-IMLOC +ENDDO +INM = 0 +DO JM=0,R%NSMAX + + INM = INM+R%NTMAX+2-JM +ENDDO + +D%NLEI3D = (R%NLEI3-1)/NPRTRW+1 + +ENDIF + +IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_PRELEG_MOD:SUEMP_TRANS_PRELEG',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ +9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) + +END SUBROUTINE SUEMP_TRANS_PRELEG +END MODULE SUEMP_TRANS_PRELEG_MOD diff --git a/src/etrans/etrans/internal/suemplat_mod.F90 b/src/etrans/etrans/internal/suemplat_mod.F90 new file mode 100644 index 000000000..c06f31695 --- /dev/null +++ b/src/etrans/etrans/internal/suemplat_mod.F90 @@ -0,0 +1,252 @@ +MODULE SUEMPLAT_MOD +CONTAINS +SUBROUTINE SUEMPLAT(KDGL,KPROC,KPROCA,KMYSETA,LDSPLIT,LDEQ_REGIONS,& + & KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& + & KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,& + & PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& + & KMEDIAP,KRESTM,LDSPLITLAT,KMYPROC,KLOEN,KDGUX) + +!**** *SUEMPLAT * - Initialize gridpoint distrbution in N-S direction + +! Purpose. +! -------- + +!** Interface. +! ---------- +! *CALL* *SUEMPLAT * + +! Explicit arguments - input : +! -------------------- +! KDGL -last latitude +! KPROC -total number of processors +! KPROCA -number of processors in A direction +! KMYSETA -process number in A direction +! LDSPLIT -true for latitudes shared between sets +! PWEIGHT -weight per grid-point if weighted +! distribution +! LDEQ_REGIONS -true if eq_regions partitioning +! LDWEIGHTED_DISTR -true if weighted distribution + +! Explicit arguments - output: +! -------------------- +! KMEDIAP -mean number of grid points per PE +! KRESTM -number of PEs with one extra point +! KFRSTLAT -first latitude row on processor +! KLSTLAT -last latitude row on processor +! KFRSTLOFF -offset for first latitude in set +! KPROCAGP -number of grid points per A set +! KPTRLAT -pointer to start of latitude +! KPTRFRSTLAT-pointer to first latitude +! KPTRLSTLAT -pointer to last latitude +! KPTRFLOFF -offset for pointer to first latitude +! LDSPLITLAT -true for latitudes which are split +! PMEDIAP -mean weight per PE if weighted +! distribution +! + +! Implicit arguments : +! -------------------- + +! Method. +! ------- +! See documentation + +! Externals. SUMPLATB and SUEMPLATB. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! MPP Group *ECMWF* + +! Modifications. +! -------------- +! Original : 95-10-01 +! David Dent:97-06-02 parameters KFRSTLAT etc added +! JF. Estrade:97-11-13 Adaptation to ALADIN case +! J.Boutahar: 98-07-06 phasing with CY19 +! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option + cleanings +! (correct computation of extrapolar latitudes for KPROCL). +! Modified 98-12-07 by K. YESSAD and C. FISCHER: cleaning. +! - merge old sumplat.F and suemplat.F +! - gather 'lelam' code and 'not lelam' code. +! - clean (useless duplication of variables, non doctor features). +! - remodularise according to lelam/not lelam +! -> lelam features in new routine suemplatb.F, +! not lelam features in new routine sumplatb.F +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Bogatchev 20-Sep-2010 Phasing cy37 +! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE TPM_GEN ,ONLY : NOUT, NPRINTLEV + +USE SUEMPLATB_MOD ,ONLY : SUEMPLATB +USE SUMPLATBEQ_MOD ,ONLY : SUMPLATBEQ +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +! * DUMMY: +INTEGER(KIND=JPIM),INTENT(OUT) :: KMEDIAP +INTEGER(KIND=JPIM),INTENT(OUT) :: KRESTM +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KPROC +INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA +INTEGER(KIND=JPIM),INTENT(IN) :: KMYSETA +INTEGER(KIND=JPIM),INTENT(OUT) :: KFRSTLAT(:) +INTEGER(KIND=JPIM),INTENT(OUT) :: KLSTLAT(:) +INTEGER(KIND=JPIM),INTENT(OUT) :: KFRSTLOFF +INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRLAT(:) +INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRFRSTLAT(:) +INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRLSTLAT(:) +INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRFLOFF +INTEGER(KIND=JPIM),INTENT(OUT) :: KPROCAGP(KPROCA) +REAL(KIND=JPRB),INTENT(OUT) :: PMEDIAP +REAL(KIND=JPRB),INTENT(IN) :: PWEIGHT(:) + +LOGICAL,INTENT(IN) :: LDSPLIT +LOGICAL,INTENT(IN) :: LDEQ_REGIONS +LOGICAL,INTENT(OUT) :: LDSPLITLAT(:) +LOGICAL,INTENT(INOUT) :: LDWEIGHTED_DISTR +INTEGER(KIND=JPIM),INTENT(IN) :: KMYPROC +INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(KDGL) +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX + +! === END OF INTERFACE BLOCK === +INTEGER(KIND=JPIM) :: INDIC(KPROCA),ILAST(KPROCA) + +INTEGER(KIND=JPIM) :: IPTRLATITUDE, JA, JGL +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +LOGICAL :: LLFOURIER +LOGICAL :: LLDEBUG=.FALSE. + +! ----------------------------------------------------------------- + +!* 1. CODE DEPENDING ON 'LELAM': COMPUTATION OF +! KMEDIAP, KRESTM, INDIC, ILAST. +! ----------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SUEMPLAT_MOD:SUEMPLAT',0,ZHOOK_HANDLE) + +INDIC(:)=0 +ILAST(:)=0 + +IF(LDWEIGHTED_DISTR.AND..NOT.LDEQ_REGIONS)THEN + CALL ABORT_TRANS ('SUEMPLAT: LDWEIGHTED_DISTR=T AND LDEQ_REGIONS=F NOT SUPPORTED') +ENDIF + +IF( LDEQ_REGIONS )THEN + CALL SUMPLATBEQ(1,KDGL,KPROC,KPROCA,KLOEN,LDSPLIT,LDEQ_REGIONS,& + &PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& + &KMEDIAP,KRESTM,INDIC,ILAST) +ELSE + LLFOURIER=.FALSE. +!REK commented out for now ... monkey business to be done again, should lead to the use of sumplatb +!REK CALL SUMPLATB(1,KDGL,KPROCA,G%NLOEN,LDSPLIT,LLFOURIER,& +!REK &KMEDIAP,KRESTM,INDIC,ILAST) + CALL SUEMPLATB(1,KDGL,KPROCA,KLOEN,LDSPLIT,& + & PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& + & KMEDIAP,KRESTM,INDIC,ILAST,KDGUX) +ENDIF + +! ----------------------------------------------------------------- + +!* 2. CODE NOT DEPENDING ON 'LELAM': COMPUTATION OF +! KFRSTLAT TO LDSPLITLAT. +! --------------------------------------------- + +! * Computation of first and last latitude of processor sets +! ----------- in grid-point-space ----------------------- +IF(KMYPROC==1.AND.LLDEBUG)THEN + WRITE(0,'("")') + WRITE(0,'("SUEMPLAT_MOD:LDWEIGHTED_DISTR=",L1)')LDWEIGHTED_DISTR + WRITE(0,'("")') + DO JA=1,KPROCA + WRITE(0,'("SUEMPLAT_MOD: JA=",I3," ILAST=",I3," INDIC=",I3)')& + &JA,ILAST(JA),INDIC(JA) + ENDDO + WRITE(0,'("")') + IF( LDEQ_REGIONS .AND. LDSPLIT )THEN + DO JA=1,KPROCA + WRITE(0,'("SUEMPLAT_MOD: JA=",I3," KPROCAGP=",I8)')& + &JA,KPROCAGP(JA) + ENDDO + WRITE(0,'("")') + ENDIF +ENDIF +KFRSTLAT(1) = 1 +KLSTLAT(KPROCA) = KDGL +DO JA=1,KPROCA-1 + IF(KMYPROC==1 .AND. NPRINTLEV > 1)THEN + WRITE(NOUT,'("SUEMPLAT_MOD: JA=",I3," ILAST=",I3," INDIC=",I3)')& + &JA,ILAST(JA),INDIC(JA) + ENDIF + IF ((.NOT. LDSPLIT) .OR. INDIC(JA) == 0) THEN + KFRSTLAT(JA+1) = ILAST(JA) + 1 + KLSTLAT(JA) = ILAST(JA) + ELSE + KFRSTLAT(JA+1) = INDIC(JA) + KLSTLAT(JA) = INDIC(JA) + ENDIF +ENDDO +KFRSTLOFF=KFRSTLAT(KMYSETA)-1 + +! * Initialise following data structures:- +! NPTRLAT (pointer to the start of each latitude) +! LSPLITLAT (TRUE if latitude is split over two A sets) +! NPTRFRSTLAT (pointer to the first latitude of each A set) +! NPTRLSTLAT (pointer to the last latitude of each A set) + +DO JGL=1,KDGL + KPTRLAT (JGL)=-999 + LDSPLITLAT(JGL)=.FALSE. +ENDDO +IPTRLATITUDE=0 +DO JA=1,KPROCA + DO JGL=KFRSTLAT(JA),KLSTLAT(JA) + IPTRLATITUDE=IPTRLATITUDE+1 + LDSPLITLAT(JGL)=.TRUE. + IF( KPTRLAT(JGL) == -999 )THEN + KPTRLAT(JGL)=IPTRLATITUDE + LDSPLITLAT(JGL)=.FALSE. + ENDIF + ENDDO +ENDDO +DO JA=1,KPROCA + IF( LDSPLITLAT(KFRSTLAT(JA)) .AND. JA /= 1 )THEN + KPTRFRSTLAT(JA)=KPTRLAT(KFRSTLAT(JA))+1 + ELSE + KPTRFRSTLAT(JA)=KPTRLAT(KFRSTLAT(JA)) + ENDIF + IF( LDSPLITLAT(KLSTLAT(JA)) .AND. JA == KPROCA)THEN + KPTRLSTLAT(JA)=KPTRLAT(KLSTLAT(JA))+1 + ELSE + KPTRLSTLAT(JA)=KPTRLAT(KLSTLAT(JA)) + ENDIF +ENDDO +KPTRFLOFF=KPTRFRSTLAT(KMYSETA)-1 +IF(KMYPROC==1 .AND. NPRINTLEV > 1)THEN + DO JGL=1,KDGL + WRITE(NOUT,'("SUEMPLAT_MOD: JGL=",I3," KPTRLAT=",I3," LDSPLITLAT=",L4)')& + & JGL,KPTRLAT(JGL),LDSPLITLAT(JGL) + ENDDO + DO JA=1,KPROCA + WRITE(NOUT,'("SUEMPLAT_MOD: JA=",I3," KFRSTLAT=",I3," KLSTLAT=",I3,& + & " KPTRFRSTLAT=",I3," KPTRLSTLAT=",I3)')& + & JA,KFRSTLAT(JA),KLSTLAT(JA),KPTRFRSTLAT(JA),KPTRLSTLAT(JA) + ENDDO +ENDIF + +IF (LHOOK) CALL DR_HOOK('SUEMPLAT_MOD:SUEMPLAT',1,ZHOOK_HANDLE) +END SUBROUTINE SUEMPLAT +END MODULE SUEMPLAT_MOD + diff --git a/src/etrans/etrans/internal/suemplatb_mod.F90 b/src/etrans/etrans/internal/suemplatb_mod.F90 new file mode 100644 index 000000000..a7361777b --- /dev/null +++ b/src/etrans/etrans/internal/suemplatb_mod.F90 @@ -0,0 +1,236 @@ +MODULE SUEMPLATB_MOD +CONTAINS +SUBROUTINE SUEMPLATB(KDGSA,KDGL,KPROCA,KLOENG,LDSPLIT,& + & PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& + & KMEDIAP,KRESTM,KINDIC,KLAST,KDGUX) + +!**** *SUMPLATB * - Routine to initialize parallel environment + +! Purpose. +! -------- + +!** Interface. +! ---------- +! *CALL* *SUMPLATB * + +! Explicit arguments - input : +! -------------------- +! KDGSA -first latitude (grid-space) +! (may be different from NDGSAG) +! KDGL -last latitude +! KPROCA -number of processors in A direction +! KLOENG -actual number of longitudes per latitude. +! LDSPLIT -true for latitudes shared between sets +! KDGUX -last latitude for meaningful computations +! (suggested to pass NDGUX in gp-space, NDGL in Fourier space +! for having a good load-balance) +! PWEIGHT -weight per grid-point if weighted distribution +! LDWEIGHTED_DISTR -true if weighted distribution` + +! Explicit arguments - output: +! -------------------- +! KMEDIAP -mean number of grid points per PE +! KPROCAGP -number of grid points per A set +! KRESTM -number of PEs with one extra point +! KINDIC -intermediate quantity for 'sumplat' +! KLAST -intermediate quantity for 'sumplat' +! PMEDIAP -mean weight per PE if weighted distribution + +! Implicit arguments : +! -------------------- + +! Method. +! ------- +! See documentation + +! Externals. NONE. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! K. YESSAD (after old version of sumplat.F). + +! Modifications. +! -------------- +! Original : 98-12-07 +! G. Radnoti: 03-03-03: Semi-merge with sumplatb, only difference: +! NS-partitioning according to NDGUX +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! A.Bogatchev 21-Sep-2010 phasing CY37 +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +! * DUMMY: +INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA +INTEGER(KIND=JPIM),INTENT(IN) :: KDGL +INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA +INTEGER(KIND=JPIM),INTENT(IN) :: KLOENG(KDGSA:KDGL) +REAL(KIND=JPRB),INTENT(IN) :: PWEIGHT(:) +LOGICAL,INTENT(IN) :: LDSPLIT +LOGICAL,INTENT(INOUT) :: LDWEIGHTED_DISTR +INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX +INTEGER(KIND=JPIM),INTENT(OUT) :: KMEDIAP +INTEGER(KIND=JPIM),INTENT(OUT) :: KRESTM +INTEGER(KIND=JPIM),INTENT(OUT) :: KINDIC(KPROCA) +INTEGER(KIND=JPIM),INTENT(OUT) :: KLAST(KPROCA) +INTEGER(KIND=JPIM),INTENT(IN) :: KPROCAGP(KPROCA) +REAL(KIND=JPRB),INTENT(IN) :: PMEDIAP + +INTEGER(KIND=JPIM) :: IPP1(KPROCA),ILAST1(KPROCA) +INTEGER(KIND=JPIM) :: IPP(KPROCA) +INTEGER(KIND=JPIM) :: IFIRST(KPROCA) + +INTEGER(KIND=JPIM) :: ICOMP, IGL, IMAXI, IMAXIOL, IMEDIA, ITOT, JA, JGL,& + & ILAST,IREST,ILIMIT,IFRST +LOGICAL :: LLDONE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ----------------------------------------------------------------- + +!* 1. COMPUTATION OF KMEDIAP, KRESTM, KINDIC, KLAST. +! ---------------------------------------------- + +! * Computation of KMEDIAP and KRESTM. + +IF (LHOOK) CALL DR_HOOK('SUEMPLATB_MOD:SUEMPLATB',0,ZHOOK_HANDLE) +IF (LDWEIGHTED_DISTR) THEN + CALL ABORT_TRANS ('SUMPLATBEQ: ALADIN CODE IS NOT PREPARED FOR WEIGHTED DISTRIBUTION') +ENDIF +IMEDIA = SUM(KLOENG(KDGSA:KDGUX)) +KMEDIAP = IMEDIA / KPROCA +IF (KMEDIAP < KLOENG(KDGL/2)) THEN + CALL ABORT_TRANS ('SUMPLATB: KPROCA TOO BIG FOR THIS RESOLUTION') +ENDIF +KRESTM = IMEDIA - KMEDIAP * KPROCA +IF (KRESTM > 0) KMEDIAP = KMEDIAP + 1 + +! * Computation of intermediate quantities KINDIC and KLAST + +IF (LDSPLIT) THEN + + IREST = 0 + ILAST =0 + DO JA=1,KPROCA + IF (JA <= KRESTM .OR. KRESTM == 0) THEN + ICOMP = KMEDIAP + ELSE + ICOMP = KMEDIAP - 1 + ENDIF + ITOT = IREST + IGL = ILAST+1 + DO JGL=IGL,KDGUX + ILAST = JGL + IF(ITOT+KLOENG(JGL) < ICOMP) THEN + ITOT = ITOT+KLOENG(JGL) + ELSEIF(ITOT+KLOENG(JGL) == ICOMP) THEN + IREST = 0 + KLAST(JA) = JGL + KINDIC(JA) = 0 + EXIT + ELSE + IREST = KLOENG(JGL) -(ICOMP-ITOT) + KLAST(JA) = JGL + KINDIC(JA) = JGL + EXIT + ENDIF + ENDDO + ENDDO + KLAST(KPROCA)=KDGL + KINDIC(KPROCA)=0 +ELSE + + KINDIC(:) = 0 + + IMAXI = KMEDIAP-1 + IMAXIOL = HUGE(IMAXIOL) + DO + ILIMIT = IMAXI + IMAXI = 0 + IFRST = KDGUX + ILAST1(:) = 0 + IPP1(:) = 0 + DO JA=KPROCA,1,-1 + IGL = IFRST + LATS:DO JGL=IGL,1,-1 + IF (IPP1(JA) < ILIMIT .OR. JA == 1) THEN + IFRST = JGL-1 + IPP1(JA) = IPP1(JA) + KLOENG(JGL) + IF(ILAST1(JA) == 0) ILAST1(JA) = JGL + ELSE + EXIT LATS + ENDIF + ENDDO LATS + IMAXI = MAX (IMAXI,IPP1(JA)) + ENDDO + IF(IMAXI >= IMAXIOL) EXIT + KLAST(:) = ILAST1(:) + IPP(:) = IPP1(:) + IMAXIOL = IMAXI + ENDDO + +! make the distribution more uniform +! ---------------------------------- + + IFIRST(1) = 0 + IF (KLAST(1) > 0) IFIRST(1) = 1 + DO JA=2,KPROCA + IF (IPP(JA) > 0) THEN + IFIRST(JA) = KLAST(JA-1)+1 + ELSE + IFIRST(JA) = 0 + ENDIF + ENDDO + + LLDONE = .FALSE. + DO WHILE( .NOT.LLDONE ) + LLDONE = .TRUE. + + DO JA=1,KPROCA-1 + IF (IPP(JA) > IPP(JA+1)) THEN + IF (IPP(JA)-IPP(JA+1) > IPP(JA+1) + 2 *& + & KLOENG(KLAST(JA)) -IPP(JA) ) THEN + IPP(JA) = IPP(JA) - KLOENG(KLAST(JA)) + IPP(JA+1) = IPP(JA+1) + KLOENG(KLAST(JA)) + IF (KLAST(JA+1) == 0) KLAST(JA+1) = KLAST(JA) + IFIRST(JA+1) = KLAST(JA) + KLAST(JA) = KLAST(JA) - 1 + IF (KLAST(JA) == 0) IFIRST(JA) = 0 + LLDONE = .FALSE. + ENDIF + ELSE + IF( IFIRST(JA+1) > 0 )THEN + IF (IPP(JA+1)-IPP(JA) >= IPP(JA) + 2 *& + & KLOENG(IFIRST(JA+1)) -IPP(JA+1) ) THEN + IPP(JA) = IPP(JA) + KLOENG(IFIRST(JA+1)) + IPP(JA+1) = IPP(JA+1) - KLOENG(IFIRST(JA+1)) + KLAST(JA) = IFIRST(JA+1) + IF (IFIRST(JA) == 0) IFIRST(JA) = KLAST(JA) + IF (KLAST(JA+1) == KLAST(JA)) THEN + KLAST(JA+1) = 0 + IFIRST(JA+1) = 0 + ELSE + IFIRST(JA+1) = IFIRST(JA+1) + 1 + ENDIF + LLDONE = .FALSE. + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + KLAST(KPROCA)=KDGL +ENDIF + +IF (LHOOK) CALL DR_HOOK('SUEMPLATB_MOD:SUEMPLATB',1,ZHOOK_HANDLE) +END SUBROUTINE SUEMPLATB +END MODULE SUEMPLATB_MOD diff --git a/src/etrans/etrans/internal/suestaonl_mod.F90 b/src/etrans/etrans/internal/suestaonl_mod.F90 new file mode 100644 index 000000000..7cd384d53 --- /dev/null +++ b/src/etrans/etrans/internal/suestaonl_mod.F90 @@ -0,0 +1,451 @@ +MODULE SUESTAONL_MOD +CONTAINS +SUBROUTINE SUESTAONL(KMEDIAP,KRESTM,LDWEIGHTED_DISTR,PWEIGHT,PMEDIAP,KPROCAGP) + +!**** *SUESTAONL * - Routine to initialize parallel environment, TAL + +! Purpose. +! -------- +! Initialize D%NSTA and D%NONL. +! Calculation of distribution of grid points to processors : +! Splitting of grid in B direction + +!** Interface. +! ---------- +! *CALL* *SUESTAONL * + +! Explicit arguments : +! -------------------- +! KMEDIAP - mean number of grid points per PE +! KRESTM - number of PEs with one extra point +! LDWEIGHTED_DISTR -true if weighted distribution +! PWEIGHT -weight per grid-point if weighted +! distribution +! PMEDIAP -mean weight per PE if weighted +! distribution +! KPROCAGP -number of grid points per A set +! Implicit arguments : +! -------------------- + +! Method. +! ------- +! See documentation + +! Externals. NONE. +! ---------- + +! Reference. +! ---------- +! ECMWF Research Department documentation of the IFS + +! Author. +! ------- +! MPP Group *ECMWF* + +! Modifications. +! -------------- +! Original : 95-10-01 +! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option. +! - removal of LRPOLE in YOMCT0. +! - removal of code under LRPOLE. +! Modified 98-12-04 C. Fischer: merge with SUESTAONL (Aladin) +! 03-03-03 G. Radnoti: no merge: only difference with +! sustaonl: ezone added to last a-set +! M.Hamrud 01-Oct-2003 CY28 Cleaning +! O.Spaniel Oct-2004 phasing for AL29 +! A.Bogatchev Sep-2010 phasing for AL37 +! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS +! R. El Khatib 26-Apr-2018 vectorization +! ------------------------------------------------------------------ + +USE PARKIND1 ,ONLY : JPIM ,JPRB +USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE MPL_MODULE ,ONLY : MPL_ALLGATHERV, MPL_RECV, MPL_SEND + +USE TPM_GEN ,ONLY : NOUT, NPRINTLEV +USE TPM_DIM ,ONLY : R +USE TPM_GEOMETRY ,ONLY : G +USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, MTAGPART, NPRCIDS, MYPROC, NPROC +USE TPMALD_DIM ,ONLY : RALD +USE SET2PE_MOD ,ONLY : SET2PE +USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & + & N_REGIONS, N_REGIONS_NS, N_REGIONS_EW +USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS +! + +IMPLICIT NONE + +INTEGER(KIND=JPIM),INTENT(IN) :: KMEDIAP +INTEGER(KIND=JPIM),INTENT(IN) :: KRESTM +REAL(KIND=JPRB),INTENT(IN) :: PWEIGHT(:) +LOGICAL,INTENT(IN) :: LDWEIGHTED_DISTR +REAL(KIND=JPRB),INTENT(IN) :: PMEDIAP +INTEGER(KIND=JPIM),INTENT(IN) :: KPROCAGP(:) + +INTEGER(KIND=JPIM) :: IXPTLAT(R%NDGL), ILSTPTLAT(R%NDGL) +INTEGER(KIND=JPIM) :: ICHK(R%NDLON,R%NDGL), ICOMBUF(R%NDGL*N_REGIONS_EW*2) + +INTEGER(KIND=JPIM) :: I1, I2, IBUFLEN, IDGLG, IDWIDE, & + & IGL, IGL1, IGL2, IGLOFF, IGPTA, & + & IGPTPRSETS, IGPTS, IGPTSP, ILEN, ILRECV, & + & ILSEND, INPLAT, INXLAT, IPOS, & + & IPROCB, IPTSRE, IRECV, & + & IREST, ISEND, ITAG, JA, JB, JGL, JL, JNPTSRE, & + & ILAT, ILON, ILOEN +INTEGER(KIND=JPIM),ALLOCATABLE :: ICOMBUFG(:) +REAL(KIND=JPRB),ALLOCATABLE :: ZWEIGHT(:,:) +INTEGER(KIND=JPIM) :: JJ, ILENG(NPROC), IOFF(NPROC) + +LOGICAL :: LLABORT +LOGICAL :: LLP1,LLP2 + +REAL(KIND=JPRB) :: ZLAT, ZLAT1(R%NDGL), ZCOMP +REAL(KIND=JPRB) :: ZDIVID(R%NDGL),ZXPTLAT(R%NDGL) + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +! ----------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SUESTAONL_MOD:SUESTAONL',0,ZHOOK_HANDLE) +IXPTLAT (:)=999999 +ILSTPTLAT(:)=999999 +LLP1 = NPRINTLEV>0 +LLP2 = NPRINTLEV>1 + +IDWIDE = R%NDGL/2 +IBUFLEN = R%NDGL*N_REGIONS_EW*2 +IDGLG = R%NDGL + +I1 = MAX( 1,D%NFRSTLAT(MY_REGION_NS)-D%NFRSTLOFF) +I2 = MIN(IDGLG,D%NLSTLAT (MY_REGION_NS)-D%NFRSTLOFF) + +ILEN = D%NLSTLAT(MY_REGION_NS) - D%NFRSTLAT(MY_REGION_NS)+1 + +IGPTPRSETS = SUM(G%NLOEN(1:D%NFRSTLAT(MY_REGION_NS)-1)) + + +IF (D%LSPLIT) THEN + IF( LEQ_REGIONS )THEN + IGPTA=0 + DO JA=1,MY_REGION_NS-1 + IGPTA = IGPTA + KPROCAGP(JA) + ENDDO + IGPTS = KPROCAGP(MY_REGION_NS) + ELSE + IF (MY_REGION_NS <= KRESTM.OR.KRESTM == 0) THEN + IF (MY_REGION_NS < N_REGIONS_NS) THEN + IGPTS = KMEDIAP + IGPTA = KMEDIAP*(MY_REGION_NS-1) + ELSE + IGPTS = KMEDIAP+SUM(G%NLOEN(RALD%NDGUX+1:R%NDGL)) + IGPTA = KMEDIAP*(MY_REGION_NS-1) + ENDIF + ELSE + IF (MY_REGION_NS < N_REGIONS_NS) THEN + IGPTS = KMEDIAP-1 + IGPTA = KMEDIAP*KRESTM+IGPTS*(MY_REGION_NS-1-KRESTM) + ELSE + IGPTS = KMEDIAP-1+SUM(G%NLOEN(RALD%NDGUX+1:R%NDGL)) + IGPTA = KMEDIAP*KRESTM+(KMEDIAP-1)*(MY_REGION_NS-1-KRESTM) + ENDIF + ENDIF + ENDIF +ELSE + IGPTA = IGPTPRSETS + IGPTS = SUM(G%NLOEN(D%NFRSTLAT(MY_REGION_NS):D%NLSTLAT(MY_REGION_NS))) +ENDIF +IGPTSP = IGPTS/N_REGIONS(MY_REGION_NS) +IREST = IGPTS-N_REGIONS(MY_REGION_NS)*IGPTSP +IXPTLAT(1) = IGPTA-IGPTPRSETS+1 +ZXPTLAT(1) = REAL(IXPTLAT(1)) +ILSTPTLAT(1) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)) +INPLAT = G%NLOEN(D%NFRSTLAT(MY_REGION_NS))-IXPTLAT(1)+1 +DO JGL=2,ILEN + IXPTLAT(JGL) = 1 + ZXPTLAT(JGL) = 1.0_JPRB + ILSTPTLAT(JGL) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) + INPLAT = INPLAT+G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) +ENDDO +ILSTPTLAT(ILEN) = G%NLOEN(D%NLSTLAT(MY_REGION_NS))-INPLAT+IGPTS + +DO JB=1,N_REGIONS_EW + DO JGL=1,R%NDGL+N_REGIONS_NS-1 + D%NSTA(JGL,JB) = 0 + D%NONL(JGL,JB) = 0 + ENDDO +ENDDO + +! grid point decomposition +! --------------------------------------- +DO JGL=1,ILEN + ZDIVID(JGL)=1._JPRB/REAL(G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1),JPRB) +ENDDO +IF( LDWEIGHTED_DISTR )THEN + ALLOCATE(ZWEIGHT(G%NLOEN(R%NDGL/2),R%NDGL)) + IGL=0 + DO JGL=1,R%NDGL + DO JL=1,G%NLOEN(JGL) + IGL=IGL+1 + ZWEIGHT(JL,JGL)=PWEIGHT(IGL) + ENDDO + ENDDO + ZCOMP=0 + IGPTS=0 +ENDIF +DO JB=1,N_REGIONS(MY_REGION_NS) + + IF( .NOT.LDWEIGHTED_DISTR )THEN + + IF (JB <= IREST) THEN + IPTSRE = IGPTSP+1 + ELSE + IPTSRE = IGPTSP + ENDIF + + DO JNPTSRE=1,IPTSRE + ZLAT = 1._JPRB + DO JGL=1,ILEN + ZLAT1(JGL) = (ZXPTLAT(JGL)-1.0_JPRB)*ZDIVID(JGL) + ENDDO + DO JGL=1,ILEN + IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN + IF (ZLAT1(JGL) < ZLAT) THEN + ZLAT=ZLAT1(JGL) + INXLAT = JGL + ENDIF + ENDIF + ENDDO + IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN + IGL=D%NPTRFLOFF+INXLAT + IF (D%NSTA(IGL,JB) == 0) THEN + D%NSTA(IGL,JB) = IXPTLAT(INXLAT) + ENDIF + D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 + ENDIF + IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 + ZXPTLAT(INXLAT) = REAL(IXPTLAT(INXLAT),JPRB) + ENDDO + + ELSE + DO WHILE ( (JB < N_REGIONS(MY_REGION_NS) .AND. ZCOMP < PMEDIAP) & + & .OR. (JB == N_REGIONS(MY_REGION_NS) .AND. IGPTS < KPROCAGP(MY_REGION_NS)) ) + + IGPTS = IGPTS + 1 + ZLAT = 1._JPRB + DO JGL=1,ILEN + ZLAT1(JGL) = (ZXPTLAT(JGL)-1.0_JPRB)*ZDIVID(JGL) + ENDDO + DO JGL=1,ILEN + IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN + IF (ZLAT1(JGL) < ZLAT) THEN + ZLAT = ZLAT1(JGL) + INXLAT = JGL + ENDIF + ENDIF + ENDDO + + IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN + IGL=D%NPTRFLOFF+INXLAT + IF (D%NSTA(IGL,JB) == 0) THEN + D%NSTA(IGL,JB) = IXPTLAT(INXLAT) + ENDIF + D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 + IF(IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1)THEN + CALL ABORT_TRANS(' SUSTAONL: IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1') + ENDIF + ILON=D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 + ILAT=D%NFRSTLAT(MY_REGION_NS)+INXLAT-1 + ILOEN=G%NLOEN(ILAT) + IF(ILON<1.OR.ILON>ILOEN)THEN + CALL ABORT_TRANS(' SUSTAONL: ILON<1.OR.ILON>ILOEN') + ENDIF + ZCOMP = ZCOMP + ZWEIGHT(ILON,ILAT) + ENDIF + IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 + ZXPTLAT(INXLAT) = REAL(IXPTLAT(INXLAT),JPRB) + ENDDO + + ZCOMP = ZCOMP - PMEDIAP + + ENDIF + +ENDDO + +IF( LDWEIGHTED_DISTR )THEN + DEALLOCATE(ZWEIGHT) +ENDIF +! Exchange local partitioning info to produce global view + +IF( NPROC > 1 )THEN + IF( LEQ_REGIONS )THEN + + ITAG = MTAGPART + IPOS = 0 + DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 + IPOS = IPOS+1 + ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,MY_REGION_EW) + IPOS = IPOS+1 + ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,MY_REGION_EW) + ENDDO + IF( IPOS > IBUFLEN )THEN + CALL ABORT_TRANS(' SUSTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') + ENDIF + ILSEND = IPOS + + DO JA=1,N_REGIONS_NS + DO JB=1,N_REGIONS(JA) + CALL SET2PE(IRECV,JA,JB,0,0) + ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 + ILENG(NPRCIDS(IRECV))=ILEN + ENDDO + ENDDO + IOFF(1)=0 + DO JJ=2,NPROC + IOFF(JJ)=IOFF(JJ-1)+ILENG(JJ-1) + ENDDO + ALLOCATE(ICOMBUFG(SUM(ILENG(:)))) + CALL MPL_ALLGATHERV(ICOMBUF(1:ILSEND),ICOMBUFG,ILENG,CDSTRING='SUSTAONL') + DO JA=1,N_REGIONS_NS + IGL1 = D%NFRSTLAT(JA) + IGL2 = D%NLSTLAT(JA) + DO JB=1,N_REGIONS(JA) + CALL SET2PE(IRECV,JA,JB,0,0) + IF(IRECV /= MYPROC) THEN + ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 + IPOS = IOFF(NPRCIDS(IRECV)) + DO JGL=IGL1,IGL2 + IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 + IPOS = IPOS+1 + D%NSTA(IGL,JB) = ICOMBUFG(IPOS) + IPOS = IPOS+1 + D%NONL(IGL,JB) = ICOMBUFG(IPOS) + ENDDO + ENDIF + ENDDO + ENDDO + DEALLOCATE(ICOMBUFG) + + ELSE + + ITAG = MTAGPART + IPOS = 0 + DO JB=1,N_REGIONS(MY_REGION_NS) + DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 + IPOS = IPOS+1 + ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,JB) + IPOS = IPOS+1 + ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,JB) + ENDDO + ENDDO + IF( IPOS > IBUFLEN )THEN + CALL ABORT_TRANS(' SUESTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') + ENDIF + ILSEND = IPOS + + DO JA=1,N_REGIONS_NS + CALL SET2PE(ISEND,JA,MY_REGION_EW,0,0) + IF(ISEND /= MYPROC) THEN + CALL MPL_SEND(ICOMBUF(1:ILSEND),KDEST=NPRCIDS(ISEND),KTAG=ITAG, & + & CDSTRING='SUESTAONL:') + ENDIF + ENDDO + DO JA=1,N_REGIONS_NS + CALL SET2PE(IRECV,JA,MY_REGION_EW,0,0) + IF(IRECV /= MYPROC) THEN + ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*N_REGIONS(JA)*2 + CALL MPL_RECV(ICOMBUF(1:ILEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, & + & KOUNT=ILRECV,CDSTRING='SUESTAONL:') + IGL1 = D%NFRSTLAT(JA) + IGL2 = D%NLSTLAT(JA) + IPOS = 0 + DO JB=1,N_REGIONS(JA) + DO JGL=IGL1,IGL2 + IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 + IPOS = IPOS+1 + D%NSTA(IGL,JB) = ICOMBUF(IPOS) + IPOS = IPOS+1 + D%NONL(IGL,JB) = ICOMBUF(IPOS) + ENDDO + ENDDO + ENDIF + ENDDO + + ENDIF +ENDIF + +! Confirm consistency of global partitioning, specifically testing for +! multiple assignments of same grid point and unassigned grid points + +LLABORT = .FALSE. +DO JGL=1,R%NDGL + DO JL=1,G%NLOEN(JGL) + ICHK(JL,JGL) = 1 + ENDDO +ENDDO +DO JA=1,N_REGIONS_NS + IGLOFF = D%NPTRFRSTLAT(JA) + DO JB=1,N_REGIONS(JA) + IGL1 = D%NFRSTLAT(JA) + IGL2 = D%NLSTLAT(JA) + DO JGL=IGL1,IGL2 + IGL = IGLOFF+JGL-IGL1 + DO JL=D%NSTA(IGL,JB),D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 + IF( ICHK(JL,JGL) /= 1 )THEN + WRITE(NOUT,'(" SUESTAONL : seta=",i4," setb=",i4,& + & " row=",I4," sta=",I4," INVALID GRID POINT")')& + & JA,JB,JGL,JL + WRITE(0,'(" SUESTAONL : seta=",i4," setb=",i4,& + & " ROW=",I4," sta=",I4," INVALID GRID POINT")')& + & JA,JB,JGL,JL + LLABORT = .TRUE. + ENDIF + ICHK(JL,JGL) = 2 + ENDDO + ENDDO + ENDDO +ENDDO +DO JGL=1,R%NDGL + DO JL=1,G%NLOEN(JGL) + IF( ICHK(JL,JGL) /= 2 )THEN + WRITE(NOUT,'(" SUESTAONL : row=",i4," sta=",i4,& + & " GRID POINT NOT ASSIGNED")') JGL,JL + LLABORT = .TRUE. + ENDIF + ENDDO +ENDDO +IF( LLABORT )THEN + WRITE(NOUT,'(" SUESTAONL : inconsistent partitioning")') + CALL ABORT_TRANS(' SUESTAONL: inconsistent partitioning') +ENDIF + +IF (LLP1) THEN + WRITE(UNIT=NOUT,FMT='('' OUTPUT FROM ROUTINE SUESTAONL '')') + WRITE(UNIT=NOUT,FMT='('' '')') + WRITE(UNIT=NOUT,FMT='('' PARTITIONING INFORMATION '')') + WRITE(UNIT=NOUT,FMT='('' '')') + IPROCB = MIN(32,N_REGIONS_EW) + WRITE(UNIT=NOUT,FMT='(17X," SETB=",32(1X,I3))') (JB,JB=1,IPROCB) + DO JA=1,N_REGIONS_NS + IPROCB = MIN(32,N_REGIONS(JA)) + WRITE(UNIT=NOUT,FMT='('' '')') + IGLOFF = D%NPTRFRSTLAT(JA) + IGL1 = D%NFRSTLAT(JA) + IGL2 = D%NLSTLAT(JA) + DO JGL=IGL1,IGL2 + IGL=IGLOFF+JGL-IGL1 + WRITE(UNIT=NOUT,FMT='(" SETA=",I3," LAT=",I3," NSTA=",& + & 32(1X,I3))') JA,JGL,(D%NSTA(IGL,JB),JB=1,IPROCB) + WRITE(UNIT=NOUT,FMT='(" SETA=",I3," LAT=",I3," D%NONL=",& + & 32(1X,I3))') JA,JGL,(D%NONL(IGL,JB),JB=1,IPROCB) + WRITE(UNIT=NOUT,FMT='('' '')') + ENDDO + WRITE(UNIT=NOUT,FMT='('' '')') + ENDDO + WRITE(UNIT=NOUT,FMT='('' '')') + WRITE(UNIT=NOUT,FMT='('' '')') +ENDIF +IF (LHOOK) CALL DR_HOOK('SUESTAONL_MOD:SUESTAONL',1,ZHOOK_HANDLE) + +! ------------------------------------------------------------------ + +END SUBROUTINE SUESTAONL +END MODULE SUESTAONL_MOD diff --git a/src/etrans/etrans/internal/tpmald_dim.F90 b/src/etrans/etrans/internal/tpmald_dim.F90 new file mode 100644 index 000000000..716334232 --- /dev/null +++ b/src/etrans/etrans/internal/tpmald_dim.F90 @@ -0,0 +1,23 @@ +MODULE TPMALD_DIM + +! Module for dimensions. + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +TYPE ALDDIM_TYPE + +! COLLOCATION GRID DIMENSIONS + +INTEGER(KIND=JPIM) :: NDGLSUR ! Number of rows of latitudes+... +INTEGER(KIND=JPIM) :: NMSMAX ! Zonal truncation +INTEGER(KIND=JPIM) :: NDGUX ! Number of rows in zone C+I +END TYPE ALDDIM_TYPE + +TYPE(ALDDIM_TYPE),ALLOCATABLE,TARGET :: ALDDIM_RESOL(:) +TYPE(ALDDIM_TYPE),POINTER :: RALD + +END MODULE TPMALD_DIM diff --git a/src/etrans/etrans/internal/tpmald_distr.F90 b/src/etrans/etrans/internal/tpmald_distr.F90 new file mode 100644 index 000000000..9f358db92 --- /dev/null +++ b/src/etrans/etrans/internal/tpmald_distr.F90 @@ -0,0 +1,23 @@ +MODULE TPMALD_DISTR + +! Module for distributed memory environment. + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +TYPE ALDDISTR_TYPE + +INTEGER(KIND=JPIM) ,POINTER :: NESM0(:) ! Address in a spectral array of (m, n=m) +INTEGER(KIND=JPIM) ,POINTER :: NCPL2M(:) ! Number of complex Laplace coefficient for m given +INTEGER(KIND=JPIM) ,POINTER :: NPME(:) ! Address for the Laplace operator and its inverse + +END TYPE ALDDISTR_TYPE + +TYPE(ALDDISTR_TYPE),ALLOCATABLE,TARGET :: ALDDISTR_RESOL(:) +TYPE(ALDDISTR_TYPE),POINTER :: DALD + +END MODULE TPMALD_DISTR + diff --git a/src/etrans/etrans/internal/tpmald_fft.F90 b/src/etrans/etrans/internal/tpmald_fft.F90 new file mode 100644 index 000000000..337dadee6 --- /dev/null +++ b/src/etrans/etrans/internal/tpmald_fft.F90 @@ -0,0 +1,20 @@ +MODULE TPMALD_FFT + +! Module for Fourier transforms. + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +TYPE ALDFFT_TYPE +REAL(KIND=JPRB) ,POINTER :: TRIGSE(:) ! list of trigonometric function values +INTEGER(KIND=JPIM),POINTER :: NFAXE(:) ! list of factors of truncation +LOGICAL :: LFFT992=.TRUE. +END TYPE ALDFFT_TYPE + +TYPE(ALDFFT_TYPE),ALLOCATABLE,TARGET :: ALDFFT_RESOL(:) +TYPE(ALDFFT_TYPE),POINTER :: TALD + +END MODULE TPMALD_FFT diff --git a/src/etrans/etrans/internal/tpmald_fields.F90 b/src/etrans/etrans/internal/tpmald_fields.F90 new file mode 100644 index 000000000..9dfda6db3 --- /dev/null +++ b/src/etrans/etrans/internal/tpmald_fields.F90 @@ -0,0 +1,17 @@ +MODULE TPMALD_FIELDS + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +TYPE ALDFIELDS_TYPE + +REAL(KIND=JPRB) ,POINTER :: RLEPINM(:) ! eigen-values of the inverse Laplace operator +END TYPE ALDFIELDS_TYPE + +TYPE(ALDFIELDS_TYPE),ALLOCATABLE,TARGET :: ALDFIELDS_RESOL(:) +TYPE(ALDFIELDS_TYPE),POINTER :: FALD + +END MODULE TPMALD_FIELDS diff --git a/src/etrans/etrans/internal/tpmald_geo.F90 b/src/etrans/etrans/internal/tpmald_geo.F90 new file mode 100644 index 000000000..326739a16 --- /dev/null +++ b/src/etrans/etrans/internal/tpmald_geo.F90 @@ -0,0 +1,22 @@ +MODULE TPMALD_GEO + +! Module containing data describing plane projection grid. + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +TYPE ALDGEO_TYPE + +! GEOGRAPHY + +REAL(KIND=JPRB) :: EYWN ! Y-reso +REAL(KIND=JPRB) :: EXWN ! X-reso +END TYPE ALDGEO_TYPE + +TYPE(ALDGEO_TYPE),ALLOCATABLE,TARGET :: ALDGEO_RESOL(:) +TYPE(ALDGEO_TYPE),POINTER :: GALD + +END MODULE TPMALD_GEO diff --git a/src/etrans/etrans/internal/tpmald_tcdis.F90 b/src/etrans/etrans/internal/tpmald_tcdis.F90 new file mode 100644 index 000000000..2b57ca50b --- /dev/null +++ b/src/etrans/etrans/internal/tpmald_tcdis.F90 @@ -0,0 +1,13 @@ +MODULE TPMALD_TCDIS + +! useless + +USE PARKIND1 ,ONLY : JPIM ,JPRB + +IMPLICIT NONE + +SAVE + +REAL(KIND=JPRB) :: TCDIS + +END MODULE TPMALD_TCDIS diff --git a/src/programs/CMakeLists.txt b/src/programs/CMakeLists.txt index b7cdc1ff3..19b19f388 100644 --- a/src/programs/CMakeLists.txt +++ b/src/programs/CMakeLists.txt @@ -39,6 +39,15 @@ foreach( prec sp dp ) parkind_${prec} trans_${prec} ) + if ( HAVE_ETRANS ) + ecbuild_add_executable(TARGET ectrans-lam-benchmark-${prec} + SOURCES ectrans-lam-benchmark.F90 + LIBS + fiat + parkind_${prec} + trans_${prec} + ) + endif() endif() endforeach() diff --git a/src/programs/ectrans-lam-benchmark.F90 b/src/programs/ectrans-lam-benchmark.F90 new file mode 100644 index 000000000..da066ae76 --- /dev/null +++ b/src/programs/ectrans-lam-benchmark.F90 @@ -0,0 +1,1479 @@ +program ectrans_lam_benchmark + +! +! Spectral transform test for Limited-Area geometry +! +! This test performs spectral to real and real to spectral transforms repeated in +! timed loop. +! +! 1) One "surface" field is always transformed: +! zspsc2(1,1:nspec2) <-> zgmvs(1:nproma,1:1,1:ngbplk) +! +! 2) A Multiple "3d" fields are transformed and can be disabled with "--nfld 0" +! +! zspsc3a(1:nlev,1:nspec2,1:nfld) <-> zgp3a(1:nproma,1:nlev,1:nfld,1:ngpblk) +! +! 3) Optionally a "3d" vorticity/divergence field is transformed to uv (wind) and +! can be enabled with "--vordiv" +! +! zspvor(1:nlev,1:nspec2) / zspdiv(1:nlev,1:nspec2) <-> zgpuv(1:nproma,1:nlev,1:2,1:ngpblk) +! +! 4) Optionally scalar derivatives can be computed for the fields described in 1) and 2) +! This must be enabled with "--scders" +! +! 5) Optionally uv East-West derivate can be computed from vorticity/divergence. +! This must be enabled with "--vordiv --uvders" +! +! +! Authors : George Mozdzynski +! Willem Deconinck +! Ioan Hadade +! Sam Hatfield +! Daan Degrauwe + +use parkind1, only: jpim, jprb, jprd +use oml_mod ,only : oml_max_threads +use omp_lib, only: omp_get_wtime +use mpl_module +use yomgstats, only: jpmaxstat +use yomhook, only : dr_hook_init + +implicit none + +integer(kind=jpim) :: istack, getstackusage +real(kind=jprb), dimension(1) :: zmaxerr(5), zerr(5) +real(kind=jprb) :: zmaxerrg + +! Output unit numbers +integer(kind=jpim), parameter :: nerr = 0 ! Unit number for STDERR +integer(kind=jpim), parameter :: nout = 6 ! Unit number for STDOUT +integer(kind=jpim), parameter :: noutdump = 7 ! Unit number for field output + +! Default parameters +integer(kind=jpim) :: nlon = 128 ! Zonal dimension +integer(kind=jpim) :: nlat = 128 ! Meridional dimension +integer(kind=jpim) :: nsmax = 0 ! Spectral meridional truncation +integer(kind=jpim) :: nmsmax = 0 ! Spectral zonal truncation +integer(kind=jpim) :: iters = 10 ! Number of iterations for transform test +integer(kind=jpim) :: nfld = 1 ! Number of scalar fields +integer(kind=jpim) :: nlev = 1 ! Number of vertical levels + +integer(kind=jpim) :: nloen(1) ! only one value needed for LAM +integer(kind=jpim) :: nflevg +integer(kind=jpim) :: nspec2 +integer(kind=jpim) :: ngptot +integer(kind=jpim) :: ngptotg +integer(kind=jpim) :: ifld +integer(kind=jpim) :: jroc +integer(kind=jpim) :: jb +integer(kind=jpim) :: nspec2g +integer(kind=jpim) :: i +integer(kind=jpim) :: ja +integer(kind=jpim) :: ib +integer(kind=jpim) :: jprtrv + +integer(kind=jpim), allocatable :: nprcids(:) +integer(kind=jpim) :: myproc, jj +integer :: jstep + +real(kind=jprd) :: ztinit, ztloop, ztstepmax, ztstepmin, ztstepavg, ztstepmed +real(kind=jprd) :: ztstepmax1, ztstepmin1, ztstepavg1, ztstepmed1 +real(kind=jprd) :: ztstepmax2, ztstepmin2, ztstepavg2, ztstepmed2 +real(kind=jprd), allocatable :: ztstep(:), ztstep1(:), ztstep2(:) + +real(kind=jprb), allocatable :: znormsp(:), znormsp0(:), znormdiv(:), znormdiv0(:) +real(kind=jprb), allocatable :: znormvor(:), znormvor0(:), znormt(:), znormt0(:) +real(kind=jprd) :: zaveave(0:jpmaxstat) + +! Grid-point space data structures +real(kind=jprb), allocatable, target :: zgmv (:,:,:,:) ! Multilevel fields at t and t-dt +real(kind=jprb), allocatable, target :: zgmvs (:,:,:) ! Single level fields at t and t-dt +real(kind=jprb), pointer :: zgp3a (:,:,:,:) ! Multilevel fields at t and t-dt +real(kind=jprb), pointer :: zgpuv (:,:,:,:) ! Multilevel fields at t and t-dt +real(kind=jprb), pointer :: zgp2 (:,:,:) ! Single level fields at t and t-dt + +! Spectral space data structures +real(kind=jprb), allocatable, target :: sp3d(:,:,:) +real(kind=jprb), pointer :: zspvor(:,:) => null() +real(kind=jprb), pointer :: zspdiv(:,:) => null() +real(kind=jprb), pointer :: zspsc3a(:,:,:) => null() +real(kind=jprb), allocatable :: zspsc2(:,:) +real(kind=jprb), allocatable :: zmeanu(:), zmeanv(:) + +logical :: lstack = .false. ! Output stack info +logical :: luserpnm = .false. +logical :: lkeeprpnm = .false. +logical :: ltrace_stats = .false. +logical :: lstats_omp = .false. +logical :: lstats_comms = .false. +logical :: lstats_mpl = .false. +logical :: lstats = .false. ! gstats statistics +logical :: lbarrier_stats = .false. +logical :: lbarrier_stats2 = .false. +logical :: ldetailed_stats = .false. +logical :: lstats_alloc = .false. +logical :: lsyncstats = .false. +logical :: lstatscpu = .false. +logical :: lstats_mem = .false. +logical :: lxml_stats = .false. +logical :: lfftw = .false. ! Use FFTW for Fourier transforms +logical :: lvordiv = .false. +logical :: lscders = .false. +logical :: luvders = .false. +logical :: lprint_norms = .false. ! Calculate and print spectral norms +logical :: lmeminfo = .false. ! Show information from FIAT routine ec_meminfo at the end + +integer(kind=jpim) :: nstats_mem = 0 +integer(kind=jpim) :: ntrace_stats = 0 +integer(kind=jpim) :: nprnt_stats = 1 + +! The multiplier of the machine epsilon used as a tolerance for correctness checking +! ncheck = 0 (the default) means that correctness checking is disabled +integer(kind=jpim) :: ncheck = 0 + +logical :: lmpoff = .false. ! Message passing switch + +! Verbosity level (0 or 1) +integer :: verbosity = 0 + +integer(kind=jpim) :: nmax_resol = 37 ! Max number of resolutions +integer(kind=jpim) :: npromatr = 0 ! nproma for trans lib +integer(kind=jpim) :: ncombflen = 1800000 ! Size of comm buffer + +integer(kind=jpim) :: nproc ! Number of procs +integer(kind=jpim) :: nthread +integer(kind=jpim) :: nprgpns = 0 ! Grid-point decomp +integer(kind=jpim) :: nprgpew = 0 ! Grid-point decomp +integer(kind=jpim) :: nprtrv = 0 ! Spectral decomp +integer(kind=jpim) :: nprtrw = 0 ! Spectral decomp +integer(kind=jpim) :: nspecresmin = 80 ! Minimum spectral resolution, for controlling nprtrw +integer(kind=jpim) :: mysetv +integer(kind=jpim) :: mysetw +integer(kind=jpim) :: mp_type = 2 ! Message passing type +integer(kind=jpim) :: mbx_size = 150000000 ! Mailbox size + +integer(kind=jpim), allocatable :: numll(:), ivset(:) +integer(kind=jpim) :: ivsetsc(1) + +integer(kind=jpim) :: nflevl + +! sumpini +integer(kind=jpim) :: isqr +logical :: lsync_trans = .false. ! Activate barrier sync + + +integer(kind=jpim) :: nproma = 0 +integer(kind=jpim) :: ngpblks +! locals +integer(kind=jpim) :: iprtrv +integer(kind=jpim) :: iprtrw +integer(kind=jpim) :: iprused, ilevpp, irest, ilev, jlev + +integer(kind=jpim) :: ndimgmv = 0 ! Third dim. of gmv "(nproma,nflevg,ndimgmv,ngpblks)" +integer(kind=jpim) :: ndimgmvs = 0 ! Second dim. gmvs "(nproma,ndimgmvs,ngpblks)" + +integer(kind=jpim) :: jbegin_uv = 0 +integer(kind=jpim) :: jend_uv = 0 +integer(kind=jpim) :: jbegin_sc = 0 +integer(kind=jpim) :: jend_sc = 0 +integer(kind=jpim) :: jbegin_scder_NS = 0 +integer(kind=jpim) :: jend_scder_NS = 0 +integer(kind=jpim) :: jbegin_scder_EW = 0 +integer(kind=jpim) :: jend_scder_EW = 0 +integer(kind=jpim) :: jbegin_uder_EW = 0 +integer(kind=jpim) :: jend_uder_EW = 0 +integer(kind=jpim) :: jbegin_vder_EW = 0 +integer(kind=jpim) :: jend_vder_EW = 0 + +logical :: ldump_values = .false. + +integer, external :: ec_mpirank +logical :: luse_mpi = .true. + +real(kind=jprb) :: zexwn, zeywn + +!=================================================================================================== + +#include "setup_trans0.h" +#include "esetup_trans.h" +#include "einv_trans.h" +#include "edir_trans.h" +#include "etrans_inq.h" +#include "especnorm.h" +#include "abor1.intfb.h" +#include "gstats_setup.intfb.h" +#include "ec_meminfo.intfb.h" + +!=================================================================================================== + +luse_mpi = detect_mpirun() + +! Setup +call get_command_line_arguments(nlon, nlat, nsmax, nmsmax, iters, nfld, nlev, lvordiv, lscders, luvders, & + & nproma, verbosity, ldump_values, lprint_norms, lmeminfo, nprgpns, nprgpew, nprtrv, nprtrw, ncheck) +! derived defaults +if ( nsmax == 0 ) nsmax = nlat/2-1 +if ( nmsmax == 0 ) nmsmax = nlon/2-1 +nflevg = nlev + +!=================================================================================================== + +if (luse_mpi) then + call mpl_init(ldinfo=(verbosity>=1)) + nproc = mpl_nproc() + myproc = mpl_myrank() +else + nproc = 1 + myproc = 1 + mpl_comm = -1 +endif +nthread = oml_max_threads() + +call dr_hook_init() + +!=================================================================================================== + +if( lstats ) call gstats(0,0) +ztinit = omp_get_wtime() + +! only output to stdout on pe 1 +!if (nproc > 1) then + !if (myproc /= 1) then + !open(unit=nout, file='output_'//char(myproc/10+48)//char(myproc+48)//'.dat') + !endif +!endif + +if (ldetailed_stats) then + lstats_omp = .true. + lstats_comms = .true. + lstats_mpl = .true. + lstatscpu = .true. + nprnt_stats = nproc + lstats_mem = .true. + lstats_alloc = .true. +endif + +!=================================================================================================== + +allocate(nprcids(nproc)) +do jj = 1, nproc + nprcids(jj) = jj +enddo + +if (nproc <= 1) then + lmpoff = .true. +endif + +! Compute nprgpns and nprgpew +! This version selects most square-like distribution +if (nproc == 0) nproc = 1 +if ( nprgpew == 0 .and. nprgpns == 0 ) then + isqr = int(sqrt(real(nproc,jprb))) + do ja = isqr, nproc + ib = nproc/ja + if (ja*ib == nproc) then + nprgpns = max(ja,ib) + nprgpew = min(ja,ib) + exit + endif + enddo +elseif (nprgpns == 0 ) then + nprgpns=nproc/nprgpew +elseif (nprgpew == 0 ) then + nprgpew=nproc/nprgpns +endif +if (nprgpns*nprgpew /= nproc) call abor1('transform_test:nprgpns*nprgpew /= nproc') + +! From sumpini, although this should be specified in namelist +if (nspecresmin == 0) nspecresmin = nproc + +! Compute nprtrv and nprtrw if not provided on the command line +if (nprtrv ==0 .and. nprtrw == 0 ) then + nprtrv=nprgpew + nprtrw=nprgpns +elseif (nprtrv == 0 ) then + nprtrv=nproc/nprtrw +elseif (nprtrw == 0 ) then + nprtrw=nproc/nprtrv +endif +if (nprtrv*nprtrw /= nproc) call abor1('transform_test:nprtrv*nprtrw /= nproc') + +mysetv=mod(myproc-1,nprtrv)+1 + +! Determine number of local levels for zonal and meridional fourier calculations +! based on the values of nflevg and nprtrv +allocate(numll(nprtrv)) +numll=nflevg/nprtrv +numll(1:modulo(nflevg,nprtrv))=numll(1:modulo(nflevg,nprtrv))+1 +ivsetsc(1)=min(nflevg+1, nprtrv) +nflevl = numll(mysetv) + +!=================================================================================================== +! Setup gstats +!=================================================================================================== + +if (lstats) then + call gstats_setup(nproc, myproc, nprcids, & + & lstats, lstatscpu, lsyncstats, ldetailed_stats, lbarrier_stats, lbarrier_stats2, & + & lstats_omp, lstats_comms, lstats_mem, nstats_mem, lstats_alloc, & + & ltrace_stats, ntrace_stats, nprnt_stats, lxml_stats) + call gstats_psut + + ! Assign labels to GSTATS regions + call gstats_labels +endif + +!=================================================================================================== +! Call ecTrans setup routines +!=================================================================================================== + +if (verbosity >= 1) write(nout,'(a)')'======= Setup ecTrans =======' + +if( lstats ) call gstats(1, 0) +call setup_trans0(kout=nout, kerr=nerr, kprintlev=merge(2, 0, verbosity == 1), & + & kmax_resol=nmax_resol, kpromatr=0, kprgpns=nprgpns, kprgpew=nprgpew, & + & kprtrw=nprtrw, kcombflen=ncombflen, ldsync_trans=lsync_trans, & + & ldalloperm=.true., ldmpoff=.not.luse_mpi) + if( lstats ) call gstats(1, 1) + + if( lstats ) call gstats(2, 0) +zexwn=1._jprb ! 2*pi/(nx*dx): spectral resolution +zeywn=1._jprb ! 2*pi/(ny*dy) +nloen=nlon +call esetup_trans(ksmax=nsmax, kmsmax=nmsmax, kdgl=nlat, kdgux=nlat, kloen=nloen, ldsplit=.true., & + & ldusefftw=lfftw,pexwn=zexwn,peywn=zeywn) + + if( lstats ) call gstats(2, 1) + +call etrans_inq(kspec2=nspec2, kspec2g=nspec2g, kgptot=ngptot, kgptotg=ngptotg) + +if (nproma == 0) then ! no blocking (default when not specified) + nproma = ngptot +endif + +! Calculate number of NPROMA blocks +ngpblks = (ngptot - 1)/nproma+1 + +!=================================================================================================== +! Print information before starting +!=================================================================================================== + +! Print configuration details +if (verbosity >= 0) then + write(nout,'(" ")') + write(nout,'(a)')'======= Start of runtime parameters =======' + write(nout,'(" ")') + write(nout,'("nlon ",i0)') nlon + write(nout,'("nlat ",i0)') nlat + write(nout,'("nsmax ",i0)') nsmax + write(nout,'("nmsmax ",i0)') nmsmax + write(nout,'("nproc ",i0)') nproc + write(nout,'("nthread ",i0)') nthread + write(nout,'("nprgpns ",i0)') nprgpns + write(nout,'("nprgpew ",i0)') nprgpew + write(nout,'("nprtrw ",i0)') nprtrw + write(nout,'("nprtrv ",i0)') nprtrv + write(nout,'("ngptot ",i0)') ngptot + write(nout,'("ngptotg ",i0)') ngptotg + write(nout,'("nfld ",i0)') nfld + write(nout,'("nlev ",i0)') nlev + write(nout,'("nflevl ",i0)') nflevl + write(nout,'("nproma ",i0)') nproma + write(nout,'("ngpblks ",i0)') ngpblks + write(nout,'("nspec2 ",i0)') nspec2 + write(nout,'("nspec2g ",i0)') nspec2g + write(nout,'("lvordiv ",l)') lvordiv + write(nout,'("lscders ",l)') lscders + write(nout,'("luvders ",l)') luvders + write(nout,'(" ")') + write(nout,'(a)') '======= End of runtime parameters =======' + write(nout,'(" ")') +end if + +!=================================================================================================== +! Allocate and Initialize spectral arrays +!=================================================================================================== + +! Allocate spectral arrays +! Try to mimick IFS layout as much as possible +nullify(zspvor) +nullify(zspdiv) +nullify(zspsc3a) +allocate(sp3d(nflevl,nspec2,2+nfld)) +allocate(zspsc2(1,nspec2)) +allocate(zmeanu(nflevl),zmeanv(nflevl)) +zmeanu(:)=0._jprb +zmeanv(:)=0._jprb + +call initialize_spectral_arrays(nsmax, nmsmax, zspsc2, sp3d) + +! Point convenience variables to storage variable sp3d +zspvor => sp3d(:,:,1) +zspdiv => sp3d(:,:,2) +zspsc3a => sp3d(:,:,3:3+(nfld-1)) + +!=================================================================================================== +! Allocate gridpoint arrays +!=================================================================================================== + +allocate(ivset(nflevg)) + +! Compute spectral distribution +ilev = 0 +do jb = 1, nprtrv + do jlev=1, numll(jb) + ilev = ilev + 1 + ivset(ilev) = jb + enddo +enddo + +! Allocate grid-point arrays +if (lvordiv) then + jbegin_uv = 1 + jend_uv = 2 +endif +if (luvders) then + jbegin_uder_EW = jend_uv + 1 + jend_uder_EW = jbegin_uder_EW + 1 + jbegin_vder_EW = jend_uder_EW + 1 + jend_vder_EW = jbegin_vder_EW + 1 +else + jbegin_uder_EW = jend_uv + jend_uder_EW = jend_uv + jbegin_vder_EW = jend_uv + jend_vder_EW = jend_uv +endif + +jbegin_sc = jend_vder_EW + 1 +jend_sc = jend_vder_EW + nfld + +if (lscders) then + ndimgmvs = 3 + jbegin_scder_NS = jend_sc + 1 + jend_scder_NS = jend_sc + nfld + jbegin_scder_EW = jend_scder_NS + 1 + jend_scder_EW = jend_scder_NS + nfld +else + ndimgmvs = 1 + jbegin_scder_NS = jend_sc + jend_scder_NS = jend_sc + jbegin_scder_EW = jend_sc + jend_scder_EW = jend_sc +endif + +ndimgmv = jend_scder_EW + +!allocate(zgmv(nproma,nflevg,ndimgmv,ngpblks)) +!allocate(zgmvs(nproma,ndimgmvs,ngpblks)) +!zgpuv => zgmv(:,:,1:jend_vder_EW,:) +!zgp3a => zgmv(:,:,jbegin_sc:jend_scder_EW,:) +!zgp2 => zgmvs(:,:,:) + +! allocate separately since non-contiguous host-device transfers are not supported. +allocate(zgpuv(nproma,nflevg,jend_vder_EW,ngpblks)) +allocate(zgp3a(nproma,nflevg,jend_scder_EW-jbegin_sc+1,ngpblks)) +allocate(zgp2(nproma,ndimgmvs,ngpblks)) + +zgp2=0. +zgp3a=0. +zgpuv=0. + +!=================================================================================================== +! Allocate norm arrays +!=================================================================================================== + +if (lprint_norms .or. ncheck > 0) then + allocate(znormsp(1)) + allocate(znormsp0(1)) + allocate(znormvor(nflevg)) + allocate(znormvor0(nflevg)) + allocate(znormdiv(nflevg)) + allocate(znormdiv0(nflevg)) + allocate(znormt(nflevg)) + allocate(znormt0(nflevg)) + + call especnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor0, kvset=ivset(1:nflevg)) + call especnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv0, kvset=ivset(1:nflevg)) + call especnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt0, kvset=ivset(1:nflevg)) + call especnorm(pspec=zspsc2(1:1,:), pnorm=znormsp0, kvset=ivsetsc) + + if (verbosity >= 1 .and. myproc == 1) then + do ifld = 1, nflevg + write(nout,'("norm zspvor( ",i4,",:) = ",f20.15)') ifld, znormvor0(ifld) + enddo + do ifld = 1, nflevg + write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15)') ifld, znormdiv0(ifld) + enddo + do ifld = 1, nflevg + write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15)') ifld, znormt0(ifld) + enddo + do ifld = 1, 1 + write(nout,'("norm zspsc2( ",i4,",:) = ",f20.15)') ifld, znormsp0(ifld) + enddo + endif +endif + +!=================================================================================================== +! Setup timers +!=================================================================================================== + +ztinit = (omp_get_wtime() - ztinit) + +if (verbosity >= 0) then + write(nout,'(" ")') + write(nout,'(a,i6,a,f9.2,a)') "transform_test initialisation, on",nproc,& + & " tasks, took",ztinit," sec" + write(nout,'(" ")') +endif + +if (iters <= 0) call abor1('transform_test:iters <= 0') + +allocate(ztstep(iters)) +allocate(ztstep1(iters)) +allocate(ztstep2(iters)) + +ztstepavg = 0._jprd +ztstepmax = 0._jprd +ztstepmin = 9999999999999999._jprd +ztstepavg1 = 0._jprd +ztstepmax1 = 0._jprd +ztstepmin1 = 9999999999999999._jprd +ztstepavg2 = 0._jprd +ztstepmax2 = 0._jprd +ztstepmin2 = 9999999999999999._jprd + +!================================================================================================= +! Dump the values to disk, for debugging only +!================================================================================================= + +if (ldump_values) then + ! dump a field to a binary file + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspsc2(1,:),ivsetsc(1:1), 'S', noutdump) + if (lvordiv) then + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspdiv(1,:),ivset(1:1), 'D', noutdump) + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspvor(1,:),ivset(1:1), 'V', noutdump) + endif + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspsc3a(1,:,1),ivset(1:1), 'T', noutdump) +endif + +write(nout,'(a)') '======= Start of spectral transforms =======' +write(nout,'(" ")') + +ztloop = omp_get_wtime() + +!=================================================================================================== +! Do spectral transform loop +!=================================================================================================== + +do jstep = 1, iters + if( lstats ) call gstats(3,0) + ztstep(jstep) = omp_get_wtime() + + !================================================================================================= + ! Do inverse transform + !================================================================================================= + + ztstep1(jstep) = omp_get_wtime() + if( lstats ) call gstats(4,0) + if (lvordiv) then + + call einv_trans(kresol=1, kproma=nproma, & + & pspsc2=zspsc2, & ! spectral surface pressure + & pspvor=zspvor, & ! spectral vorticity + & pspdiv=zspdiv, & ! spectral divergence + & pspsc3a=zspsc3a, & ! spectral scalars + & ldscders=lscders, & + & ldvorgp=.false., & ! no gridpoint vorticity + & lddivgp=.false., & ! no gridpoint divergence + & lduvder=luvders, & + & kvsetuv=ivset, & + & kvsetsc2=ivsetsc, & + & kvsetsc3a=ivset, & + & pgp2=zgp2, & + & pgpuv=zgpuv, & + & pgp3a=zgp3a, & + & pmeanu=zmeanu, & + & pmeanv=zmeanv) + + else + + call einv_trans(kresol=1, kproma=nproma, & + & pspsc2=zspsc2, & ! spectral surface pressure + & pspsc3a=zspsc3a, & ! spectral scalars + & ldscders=lscders, & ! scalar derivatives + & kvsetsc2=ivsetsc, & + & kvsetsc3a=ivset, & + & pgp2=zgp2, & + & pgp3a=zgp3a) + + endif + + if( lstats ) call gstats(4,1) + + ztstep1(jstep) = (omp_get_wtime() - ztstep1(jstep)) + + !================================================================================================= + ! While in grid point space, dump the values to disk, for debugging only + !================================================================================================= + + if (ldump_values) then + ! dump a field to a binary file + call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgp2(:,1,:), 'S', noutdump) + if (lvordiv) then + call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgpuv(:,nflevg,1,:), 'U', noutdump) + call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgpuv(:,nflevg,2,:), 'V', noutdump) + endif + call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgp3a(:,nflevg,1,:), 'T', noutdump) + endif + + !================================================================================================= + ! Do direct transform + !================================================================================================= + + ztstep2(jstep) = omp_get_wtime() + + if( lstats ) call gstats(5,0) + + + if (lvordiv) then + call edir_trans(kresol=1, kproma=nproma, & + & pgp2=zgp2(:,1:1,:), & + & pgpuv=zgpuv(:,:,1:2,:), & + & pgp3a=zgp3a(:,:,1:nfld,:), & + & pspvor=zspvor, & + & pspdiv=zspdiv, & + & pspsc2=zspsc2, & + & pspsc3a=zspsc3a, & + & kvsetuv=ivset, & + & kvsetsc2=ivsetsc, & + & kvsetsc3a=ivset, & + & pmeanu=zmeanu, & + & pmeanv=zmeanv) + else + + call edir_trans(kresol=1, kproma=nproma, & + & pgp2=zgp2(:,1:1,:), & + & pgp3a=zgp3a(:,:,1:nfld,:), & + & pspsc2=zspsc2, & + & pspsc3a=zspsc3a, & + & kvsetsc2=ivsetsc, & + & kvsetsc3a=ivset) + endif + if( lstats ) call gstats(5,1) + ztstep2(jstep) = (omp_get_wtime() - ztstep2(jstep)) + + !================================================================================================= + ! Dump the values to disk, for debugging only + !================================================================================================= + + if (ldump_values) then + ! dump a field to a binary file + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspsc2(1,:),ivsetsc(1:1), 'S', noutdump) + if (lvordiv) then + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspdiv(1,:),ivset(1), 'D', noutdump) + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspvor(1,:),ivset(1:1), 'V', noutdump) + endif + call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspsc3a(1,:,1),ivset(1:1), 'T', noutdump) + endif + + !================================================================================================= + ! Calculate timings + !================================================================================================= + + ztstep(jstep) = (omp_get_wtime() - ztstep(jstep)) + + ztstepavg = ztstepavg + ztstep(jstep) + ztstepmin = min(ztstep(jstep), ztstepmin) + ztstepmax = max(ztstep(jstep), ztstepmax) + + ztstepavg1 = ztstepavg1 + ztstep1(jstep) + ztstepmin1 = min(ztstep1(jstep), ztstepmin1) + ztstepmax1 = max(ztstep1(jstep), ztstepmax1) + + ztstepavg2 = ztstepavg2 + ztstep2(jstep) + ztstepmin2 = min(ztstep2(jstep), ztstepmin2) + ztstepmax2 = max(ztstep2(jstep), ztstepmax2) + + !================================================================================================= + ! Print norms + !================================================================================================= + + if (lprint_norms) then + if( lstats ) call gstats(6,0) + call especnorm(pspec=zspsc2(1:1,:), pnorm=znormsp, kvset=ivsetsc(1:1)) + call especnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset(1:nflevg)) + call especnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset(1:nflevg)) + call especnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt, kvset=ivset(1:nflevg)) + + if ( myproc == 1 ) then + + ! Surface pressure + zmaxerr(:) = -999.0 + do ifld = 1, 1 + zerr(1) = abs(znormsp(ifld)/znormsp0(ifld) - 1.0_jprb) + zmaxerr(1) = max(zmaxerr(1), zerr(1)) + enddo + ! Divergence + do ifld = 1, nflevg + zerr(2) = abs(znormdiv(ifld)/znormdiv0(ifld) - 1.0_jprb) + zmaxerr(2) = max(zmaxerr(2), zerr(2)) + enddo + ! Vorticity + do ifld = 1, nflevg + zerr(3) = abs(znormvor(ifld)/znormvor0(ifld) - 1.0_jprb) + zmaxerr(3) = max(zmaxerr(3),zerr(3)) + enddo + ! Temperature + do ifld = 1, nflevg + zerr(4) = abs(znormt(ifld)/znormt0(ifld) - 1.0_jprb) + zmaxerr(4) = max(zmaxerr(4), zerr(4)) + enddo + write(nout,'("time step ",i6," took", f8.4," | zspvor max err="e10.3,& + & " | zspdiv max err="e10.3," | zspsc3a max err="e10.3," | zspsc2 max err="e10.3)') & + & jstep, ztstep(jstep), zmaxerr(3), zmaxerr(2), zmaxerr(4), zmaxerr(1) + if( lstats )call gstats(6,1) + else + write(nout,'("Time step ",i6," took", f8.4)') jstep, ztstep(jstep) + endif + + endif + + if( lstats ) call gstats(3,1) + +enddo + +!=================================================================================================== + +ztloop = (omp_get_wtime() - ztloop) + +write(nout,'(" ")') +write(nout,'(a)') '======= End of spectral transforms =======' +write(nout,'(" ")') + +if (lprint_norms .or. ncheck > 0) then + call especnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset) + call especnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset) + call especnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt, kvset=ivset) + call especnorm(pspec=zspsc2(1:1,:), pnorm=znormsp, kvset=ivsetsc) + + if ( myproc == 1 ) then + + zmaxerr(:) = -999.0 + do ifld = 1, nflevg + zerr(3) = abs(real(znormvor(ifld),kind=jprd)/real(znormvor0(ifld),kind=jprd) - 1.0_jprd) + zmaxerr(3) = max(zmaxerr(3), zerr(3)) + if (verbosity >= 1) then + write(nout,'("norm zspvor( ",i4,") = ",f20.15," error = ",e10.3)') ifld, znormvor0(ifld), zerr(3) + endif + enddo + do ifld = 1, nflevg + zerr(2) = abs(real(znormdiv(ifld),kind=jprd)/real(znormdiv0(ifld),kind=jprd) - 1.0d0) + zmaxerr(2) = max(zmaxerr(2),zerr(2)) + if (verbosity >= 1) then + write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15," error = ",e10.3)') ifld, znormdiv0(ifld), zerr(2) + endif + enddo + do ifld = 1, nflevg + zerr(4) = abs(real(znormt(ifld),kind=jprd)/real(znormt0(ifld),kind=jprd) - 1.0d0) + zmaxerr(4) = max(zmaxerr(4), zerr(4)) + if (verbosity >= 1) then + write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15," error = ",e10.3)') ifld, znormt0(ifld), zerr(4) + endif + enddo + do ifld = 1, 1 + zerr(1) = abs(real(znormsp(ifld),kind=jprd)/real(znormsp0(ifld),kind=jprd) - 1.0d0) + zmaxerr(1) = max(zmaxerr(1), zerr(1)) + if (verbosity >= 1) then + write(nout,'("norm zspsc2( ",i4,",:) = ",f20.15," error = ",e10.3)') ifld, znormsp0(ifld), zerr(1) + endif + enddo + + ! maximum error across all fields + zmaxerrg = max(max(zmaxerr(1),zmaxerr(2)), max(zmaxerr(2), zmaxerr(3))) + + if (verbosity >= 1) write(nout,*) + write(nout,'("max error zspvor(1:nlev,:) = ",e10.3)') zmaxerr(3) + write(nout,'("max error zspdiv(1:nlev,:) = ",e10.3)') zmaxerr(2) + write(nout,'("max error zspsc3a(1:nlev,:,1) = ",e10.3)') zmaxerr(4) + write(nout,'("max error zspsc2(1:1,:) = ",e10.3)') zmaxerr(1) + write(nout,*) + write(nout,'("max error combined = = ",e10.3)') zmaxerrg + write(nout,*) + + if (ncheck > 0) then + ! If the maximum spectral norm error across all fields is greater than 100 times the machine + ! epsilon, fail the test + if (zmaxerrg > real(ncheck, jprb) * epsilon(1.0_jprb)) then + write(nout, '(a)') '*******************************' + write(nout, '(a)') 'Correctness test failed' + write(nout, '(a,1e7.2)') 'Maximum spectral norm error = ', zmaxerrg + write(nout, '(a,1e7.2)') 'Error tolerance = ', real(ncheck, jprb) * epsilon(1.0_jprb) + write(nout, '(a)') '*******************************' + error stop + endif + endif + endif +endif + +if (luse_mpi) then + call mpl_allreduce(ztloop, 'sum', ldreprod=.false.) + call mpl_allreduce(ztstep, 'sum', ldreprod=.false.) + call mpl_allreduce(ztstepavg, 'sum', ldreprod=.false.) + call mpl_allreduce(ztstepmax, 'max', ldreprod=.false.) + call mpl_allreduce(ztstepmin, 'min', ldreprod=.false.) + + call mpl_allreduce(ztstep1, 'sum', ldreprod=.false.) + call mpl_allreduce(ztstepavg1, 'sum', ldreprod=.false.) + call mpl_allreduce(ztstepmax1, 'max', ldreprod=.false.) + call mpl_allreduce(ztstepmin1, 'min', ldreprod=.false.) + + call mpl_allreduce(ztstep2, 'sum', ldreprod=.false.) + call mpl_allreduce(ztstepavg2, 'sum', ldreprod=.false.) + call mpl_allreduce(ztstepmax2, 'max', ldreprod=.false.) + call mpl_allreduce(ztstepmin2, 'min', ldreprod=.false.) +endif + +ztstepavg = (ztstepavg/real(nproc,jprb))/real(iters,jprd) +ztloop = ztloop/real(nproc,jprd) +ztstep(:) = ztstep(:)/real(nproc,jprd) + +call sort(ztstep,iters) +ztstepmed = ztstep(iters/2) + +ztstepavg1 = (ztstepavg1/real(nproc,jprb))/real(iters,jprd) +ztstep1(:) = ztstep1(:)/real(nproc,jprd) + +call sort(ztstep1, iters) +ztstepmed1 = ztstep1(iters/2) + +ztstepavg2 = (ztstepavg2/real(nproc,jprb))/real(iters,jprd) +ztstep2(:) = ztstep2(:)/real(nproc,jprd) + +call sort(ztstep2,iters) +ztstepmed2 = ztstep2(iters/2) + + +write(nout,'(a)') '======= Start of time step stats =======' +write(nout,'(" ")') +write(nout,'("Inverse transforms")') +write(nout,'("------------------")') +write(nout,'("avg (s): ",f8.4)') ztstepavg1 +write(nout,'("min (s): ",f8.4)') ztstepmin1 +write(nout,'("max (s): ",f8.4)') ztstepmax1 +write(nout,'("med (s): ",f8.4)') ztstepmed1 +write(nout,'(" ")') +write(nout,'("Direct transforms")') +write(nout,'("-----------------")') +write(nout,'("avg (s): ",f8.4)') ztstepavg2 +write(nout,'("min (s): ",f8.4)') ztstepmin2 +write(nout,'("max (s): ",f8.4)') ztstepmax2 +write(nout,'("med (s): ",f8.4)') ztstepmed2 +write(nout,'(" ")') +write(nout,'("Inverse-direct transforms")') +write(nout,'("-------------------------")') +write(nout,'("avg (s): ",f8.4)') ztstepavg +write(nout,'("min (s): ",f8.4)') ztstepmin +write(nout,'("max (s): ",f8.4)') ztstepmax +write(nout,'("med (s): ",f8.4)') ztstepmed +write(nout,'("loop (s): ",f8.4)') ztloop +write(nout,'(" ")') +write(nout,'(a)') '======= End of time step stats =======' +write(nout,'(" ")') + +if (lstack) then + ! Gather stack usage statistics + istack = getstackusage() + if (myproc == 1) then + print 9000, istack + 9000 format("Stack utilisation information",/,& + &"=============================",//,& + &"Task size(bytes)",/,& + &"==== ===========",//,& + &" 1",11x,i10) + + do i = 2, nproc + call mpl_recv(istack, ksource=nprcids(i), ktag=i, cdstring='transform_test:') + print '(i4,11x,i10)', i, istack + enddo + else + call mpl_send(istack, kdest=nprcids(1), ktag=myproc, cdstring='transform_test:') + endif +endif + +!=================================================================================================== +! Cleanup +!=================================================================================================== + +! TODO: many more arrays to deallocate + +!=================================================================================================== + +if (lstats) then + call gstats(0,1) + call gstats_print(nout, zaveave, jpmaxstat) +endif + +if (lmeminfo) then + write(nout,*) + call ec_meminfo(nout, "", mpl_comm, kbarr=1, kiotask=-1, & + & kcall=1) +endif + +!=================================================================================================== +! Finalize MPI +!=================================================================================================== + +if (luse_mpi) then + call mpl_end(ldmeminfo=.false.) +endif + +!=================================================================================================== +! Close file +!=================================================================================================== + +if (nproc > 1) then + if (myproc /= 1) then + close(unit=nout) + endif +endif + +!=================================================================================================== + +contains + +!=================================================================================================== + +function get_int_value(cname, iarg) result(value) + + integer :: value + character(len=*), intent(in) :: cname + integer, intent(inout) :: iarg + character(len=128) :: carg + integer :: stat + + carg = get_str_value(cname, iarg) + call str2int(carg, value, stat) + + if (stat /= 0) then + call parsing_failed("Invalid argument for " // trim(cname) // ": " // trim(carg)) + end if + +end function + +!=================================================================================================== + +function get_str_value(cname, iarg) result(value) + + character(len=128) :: value + character(len=*), intent(in) :: cname + integer, intent(inout) :: iarg + + iarg = iarg + 1 + call get_command_argument(iarg, value) + + if (value == "") then + call parsing_failed("Invalid argument for " // trim(cname) // ": no value provided") + end if + +end function + +!=================================================================================================== + +subroutine parsing_failed(message) + + character(len=*), intent(in) :: message + if (luse_mpi) call mpl_init(ldinfo=.false.) + if (ec_mpirank() == 0) then + write(nerr,"(a)") trim(message) + call print_help(unit=nerr) + endif + if (luse_mpi) call mpl_end(ldmeminfo=.false.) + stop + +end subroutine + +!=================================================================================================== + +subroutine get_command_line_arguments(nlon, nlat, nsmax, nmsmax, & + & iters, nfld, nlev, lvordiv, lscders, luvders, & + & nproma, verbosity, ldump_values, lprint_norms, & + & lmeminfo, nprgpns, nprgpew, nprtrv, nprtrw, ncheck) + + integer, intent(inout) :: nlon ! Zonal dimension + integer, intent(inout) :: nlat ! Meridional dimension + integer, intent(inout) :: nsmax ! Meridional truncation + integer, intent(inout) :: nmsmax ! Zonal trunciation + integer, intent(inout) :: iters ! Number of iterations for transform test + integer, intent(inout) :: nfld ! Number of scalar fields + integer, intent(inout) :: nlev ! Number of vertical levels + logical, intent(inout) :: lvordiv ! Also transform vorticity/divergence + logical, intent(inout) :: lscders ! Compute scalar derivatives + logical, intent(inout) :: luvders ! Compute uv East-West derivatives + integer, intent(inout) :: nproma ! NPROMA + integer, intent(inout) :: verbosity ! Level of verbosity + logical, intent(inout) :: ldump_values ! Dump values of grid point fields for debugging + logical, intent(inout) :: lprint_norms ! Calculate and print spectral norms of fields + logical, intent(inout) :: lmeminfo ! Show information from FIAT ec_meminfo routine at the + ! end + integer, intent(inout) :: nprgpns ! Size of NS set (gridpoint decomposition) + integer, intent(inout) :: nprgpew ! Size of EW set (gridpoint decomposition) + integer, intent(inout) :: nprtrv ! Size of V set (spectral decomposition) + integer, intent(inout) :: nprtrw ! Size of W set (spectral decomposition) + integer, intent(inout) :: ncheck ! The multiplier of the machine epsilon used as a + ! tolerance for correctness checking + + character(len=128) :: carg ! Storage variable for command line arguments + integer :: iarg = 1 ! Argument index + integer :: stat ! For storing success status of string->integer conversion + integer :: myproc + + do while (iarg <= command_argument_count()) + call get_command_argument(iarg, carg) + + select case(carg) + ! Parse help argument + case('-h', '--help') + if (luse_mpi) call mpl_init(ldinfo=.false.) + if (ec_mpirank()==0) call print_help() + if (luse_mpi) call mpl_end(ldmeminfo=.false.) + stop + ! Parse verbosity argument + case('-v') + verbosity = 1 + ! Parse number of iterations argument + case('-n', '--niter') + iters = get_int_value('-n', iarg) + if (iters < 1) then + call parsing_failed("Invalid argument for -n: must be > 0") + end if + ! Parse spectral truncation argument + case('--nlon'); nlon = get_int_value('--nlon', iarg) + case('--nlat'); nlat = get_int_value('--nlat', iarg) + case('--nsmax'); nsmax = get_int_value('--nsmax', iarg) + case('--nmsmax'); nmsmax = get_int_value('--nmsmax', iarg) + case('-f', '--nfld'); nfld = get_int_value('-f', iarg) + case('-l', '--nlev'); nlev = get_int_value('-l', iarg) + case('--vordiv'); lvordiv = .True. + case('--scders'); lscders = .True. + case('--uvders'); luvders = .True. + case('--nproma'); nproma = get_int_value('--nproma', iarg) + case('--dump-values'); ldump_values = .true. + case('--norms'); lprint_norms = .true. + case('--meminfo'); lmeminfo = .true. + case('--nprgpns'); nprgpns = get_int_value('--nprgpns', iarg) + case('--nprgpew'); nprgpew = get_int_value('--nprgpew', iarg) + case('--nprtrv'); nprtrv = get_int_value('--nprtrv', iarg) + case('--nprtrw'); nprtrw = get_int_value('--nprtrw', iarg) + case('-c', '--check'); ncheck = get_int_value('-c', iarg) + case default + call parsing_failed("Unrecognised argument: " // trim(carg)) + + end select + iarg = iarg + 1 + end do + + if (.not. lvordiv) then + luvders = .false. + endif + +end subroutine get_command_line_arguments + +!=================================================================================================== + +subroutine str2int(str, int, stat) + + character(len=*), intent(in) :: str + integer, intent(out) :: int + integer, intent(out) :: stat + read(str, *, iostat=stat) int + +end subroutine str2int + +!=================================================================================================== + +subroutine sort(a, n) + + real(kind=jprd), intent(inout) :: a(n) + integer(kind=jpim), intent(in) :: n + + real(kind=jprd) :: x + + integer :: i, j + + do i = 2, n + x = a(i) + j = i - 1 + do while (j >= 1) + if (a(j) <= x) exit + a(j + 1) = a(j) + j = j - 1 + end do + a(j + 1) = x + end do + +end subroutine sort + +!=================================================================================================== + +subroutine print_help(unit) + + integer, optional :: unit + integer :: nout = 6 + if (present(unit)) then + nout = unit + endif + + write(nout, "(a)") "" + + if (jprb == jprd) then + write(nout, "(a)") "NAME ectrans-lam-benchmark-dp" + else + write(nout, "(a)") "NAME ectrans-lam-benchmark-sp" + end if + write(nout, "(a)") "" + + write(nout, "(a)") "DESCRIPTION" + write(nout, "(a)") " This program tests ecTrans-lam by transforming fields back and forth& + & between spectral " + if (jprb == jprd) then + write(nout, "(a)") " space and grid-point space (double-precision version)" + else + write(nout, "(a)") " space and grid-point space (single-precision version)" + end if + write(nout, "(a)") "" + + write(nout, "(a)") "USAGE" + if (jprb == jprd) then + write(nout, "(a)") " ectrans-lam-benchmark-dp [options]" + else + write(nout, "(a)") " ectrans-lam-benchmark-sp [options]" + end if + write(nout, "(a)") "" + + write(nout, "(a)") "OPTIONS" + write(nout, "(a)") " -h, --help Print this message" + write(nout, "(a)") " -v Run with verbose output" + write(nout, "(a)") " --nlon NLON Number of gridpoints in zonal direction (default = 128)" + write(nout, "(a)") " --nlat NLAT Number of gridpoints in meridional direction (default = 128)" + write(nout, "(a)") " --nsmax NSMAX Spectral truncation in meridional direction (default = NLAT/2-1)" + write(nout, "(a)") " --nmsmax NMSMAX Spectral truncation in zonal direction (default = NLON/2-1)" + write(nout, "(a)") " -n, --niter NITER Run for this many inverse/direct transform& + & iterations (default = 10)" + write(nout, "(a)") " -f, --nfld NFLD Number of scalar fields (default = 1)" + write(nout, "(a)") " -l, --nlev NLEV Number of vertical levels (default = 1)" + write(nout, "(a)") " --vordiv Also transform vorticity-divergence to wind" + write(nout, "(a)") " --scders Compute scalar derivatives (default off)" + write(nout, "(a)") " --uvders Compute uv East-West derivatives (default off). Only& + & when also --vordiv is given" + write(nout, "(a)") " --nproma NPROMA Run with NPROMA (default no blocking: NPROMA=ngptot)" + write(nout, "(a)") " --norms Calculate and print spectral norms of transformed& + & fields" + write(nout, "(a)") " The computation of spectral norms will skew overall& + & timings" + write(nout, "(a)") " --meminfo Show diagnostic information from FIAT's ec_meminfo& + & subroutine on memory usage, thread-binding etc." + write(nout, "(a)") " --nprgpew Size of East-West set in gridpoint decomposition" + write(nout, "(a)") " --nprgpns Size of North-South set in gridpoint decomposition" + write(nout, "(a)") " --nprtrv Size of Vertical set in spectral decomposition" + write(nout, "(a)") " --nprtrw Size of Wave set in spectral decomposition" + write(nout, "(a)") " -c, --check VALUE The multiplier of the machine epsilon used as a& + & tolerance for correctness checking" + write(nout, "(a)") "" + write(nout, "(a)") "DEBUGGING" + write(nout, "(a)") " --dump-values Output gridpoint fields in unformatted binary file" + write(nout, "(a)") "" + +end subroutine print_help + +!=================================================================================================== + +subroutine initialize_spectral_arrays(nsmax, nmsmax, zsp, sp3d) + + integer, intent(in) :: nsmax ! Spectral truncation in meridional direction + integer, intent(in) :: nmsmax ! Spectral truncation in zonal direction + real(kind=jprb), intent(inout) :: zsp(:,:) ! Surface pressure + real(kind=jprb), intent(inout) :: sp3d(:,:,:) ! 3D fields + + integer(kind=jpim) :: nflevl + integer(kind=jpim) :: nfield + + integer :: i, j + + nflevl = size(sp3d, 1) + nfield = size(sp3d, 3) + + ! First initialize surface pressure + call initialize_2d_spectral_field(nsmax, nmsmax, zsp(1,:)) + + ! Then initialize all of the 3D fields + do i = 1, nflevl + do j = 1, nfield + call initialize_2d_spectral_field(nsmax, nmsmax, sp3d(i,:,j)) + end do + end do + +end subroutine initialize_spectral_arrays + +!=================================================================================================== + +subroutine initialize_2d_spectral_field(nsmax, nmsmax, field) + + integer, intent(in) :: nsmax ! Spectral truncation in meridional direction + integer, intent(in) :: nmsmax ! Spectral truncation in zonal direction + real(kind=jprb), intent(inout) :: field(:) ! Field to initialize + + integer :: ispec, kspec2 + integer, allocatable :: my_km(:), my_kn(:) + + ! Choose a harmonic to initialize arrays + integer :: m_num = 1 ! Zonal wavenumber + integer :: n_num = 0 ! Meridional wavenumber + + ! Type of initialization: (single) 'harmonic' or (random) 'spectrum' + character(len=32) :: init_type='harmonic' + + ! First initialise all spectral coefficients to zero + field(:) = 0.0 + + ! make sure wavenumbers are within truncation + if ( m_num>nmsmax .or. n_num > nsmax .or. & + & ( nsmax>0 .and. nmsmax>0 .and. ( (m_num/real(nmsmax))**2+(n_num/real(nsmax))**2 ) > 1.) ) then + write (nerr,*) + write (nerr,*) 'WARNING: INITIAL WAVENUMBERS OUTSIDE OF TRUNCATION! ' + write (nerr,*) ' m_num = ',m_num,'; nmsmax = ',nmsmax,'; n_num = ',n_num,'; nsmax = ',nsmax,& + & '; ellips check: ',(m_num/real(nmsmax))**2+(n_num/real(nsmax))**2 + write (nerr,*) ' using (kx=',NMSMAX/2,', ky=', NSMAX/2,') instead' + write (nerr,*) + m_num=nmsmax/2 + n_num=nsmax/2 + endif + + ! Get wavenumbers this rank is responsible for + call etrans_inq(kspec2=kspec2) + allocate(my_kn(kspec2),my_km(kspec2)) + call etrans_inq(knvalue=my_kn,kmvalue=my_km) + + ! If rank is responsible for the chosen zonal wavenumber... + if ( init_type == 'harmonic' ) then + do ispec=1,nspec2,4 + if ( my_kn(ispec)== n_num .and. my_km(ispec) == m_num ) then + field(ispec)=1.0 ! cos*cos + !field(ispec+1)=1.0 ! cos*sin + !field(ispec+2)=1.0 ! sin*cos + !field(ispec+3)=1.0 ! sin*sin + end if + enddo + endif + + ! random power spectrum + if ( init_type == 'spectrum' ) then + call random_number(field) + field=2*field-1. ! center around zero + ! set some components to zero because they are unphysical + do ispec=1,nspec2,4 + if ( my_kn(ispec)== 0 .and. my_km(ispec) == 0 ) field(ispec:ispec+3)=0. ! remove mean value for vorticity and divergence + if ( my_kn(ispec)== 0 ) field(ispec+1:ispec+3:2)=0. ! remove sine component on zero-wavenumber + if ( my_kn(ispec)== nmsmax ) field(ispec+1:ispec+3:2)=0. ! remove sine component on last-wavenumber + if ( my_km(ispec)== 0 ) field(ispec+2:ispec+3)=0. ! remove sine component on zero-wavenumber + if ( my_km(ispec)== nsmax ) field(ispec+2:ispec+3)=0. ! remove sine component on last-wavenumber + enddo + + ! scale according to wavenumber**2 + do ispec=1,nspec2 + field(ispec)=field(ispec)/(0.01+(my_kn(ispec)/real(nsmax))**2+(my_km(ispec)/real(nmsmax))**2) + enddo + endif + +end subroutine initialize_2d_spectral_field + +!=================================================================================================== + +subroutine dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, fld, fldchar, noutdump) + + ! Dump a 2d gridpoint field to screen or a binary file. + + integer(kind=jpim), intent(in) :: jstep ! Time step, used for naming file + integer(kind=jpim), intent(in) :: myproc ! MPI rank, used for naming file + integer(kind=jpim), intent(in) :: nlat ! Number of latitudes + integer(kind=jpim), intent(in) :: nproma ! Size of nproma + integer(kind=jpim), intent(in) :: ngpblks ! Number of nproma blocks + real(kind=jprb) , intent(in) :: fld(nproma,1,ngpblks) ! 2D field + character , intent(in) :: fldchar ! Single character field identifier + integer(kind=jpim), intent(in) :: noutdump ! Unit number for output file + + integer(kind=jpim) :: kgptotg ! global number of gridpoints + real(kind=jprb), allocatable :: fldg(:,:) ! global field + integer(kind=jpim) :: kfgathg=1 ! number of fields to gather + integer(kind=jpim) :: kto(1)=(/1/) ! processor where to gather + character(len=14) :: filename = "x.xxx.xxx.grid" + character(len=13) :: frmt='(4X,xxxxF8.2)' + +#include "etrans_inq.h" +#include "egath_grid.h" + + call etrans_inq(kgptotg=kgptotg) + + if ( myproc == 1 ) allocate(fldg(kgptotg,1)) + + call egath_grid(pgpg=fldg,kproma=nproma,kfgathg=kfgathg,kto=kto,pgp=fld) + + if ( myproc == 1 ) then + + ! write to file + write(filename(1:1),'(a1)') fldchar + write(filename(3:5),'(i3.3)') jstep +#ifdef ACCGPU + write(filename(7:9),'(a3)') 'gpu' +#else + write(filename(7:9),'(a3)') 'cpu' +#endif + open(noutdump, file=filename, form="unformatted", access="stream") + write(noutdump) kgptotg/nlat,nlat ! dimensions + write(noutdump) fldg ! data + close(noutdump) + + ! write to screen + write(frmt(5:8),'(i4.4)') kgptotg/nlat + write (*,*) fldchar,' at iteration ',jstep,':' + write (*,frmt) fldg + call flush(6) + + deallocate(fldg) + + endif + + +end subroutine dump_gridpoint_field + +!=================================================================================================== + +subroutine dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, fld, kvset, fldchar, noutdump) + + ! Dump a 2d spectral field to screen or a binary file. + + integer(kind=jpim), intent(in) :: jstep ! Time step, used for naming file + integer(kind=jpim), intent(in) :: myproc ! MPI rank, used for naming file + integer(kind=jpim), intent(in) :: nspec2 ! Size of nspec2 (number of waves on this proc in M-space) + integer(kind=jpim), intent(in) :: nsmax + integer(kind=jpim), intent(in) :: nmsmax + real(kind=jprb) , intent(in) :: fld(1,nspec2) ! 2D field + integer(kind=jpim), intent(in) :: kvset(1) ! B-set on which the field resides + character , intent(in) :: fldchar ! Single character field identifier + integer(kind=jpim), intent(in) :: noutdump ! Unit number for output file + + integer(kind=jpim) :: nspec2g ! global number of gridpoints + real(kind=jprb), allocatable :: fldg(:,:) ! global field (nspec2g) + integer(kind=jpim) :: kfgathg=1 ! number of fields to gather + integer(kind=jpim) :: kto(1)=(/1/) ! processor where to gather + character(len=14) :: filename = "x.xxx.xxx.spec" + character(len=13) :: frmt='(4X,xxxxF8.2)' ! for printing to screen + integer(kind=jpim) :: knse(0:nmsmax),kmse(0:nsmax) ! elliptic truncation + real(kind=jprb) :: fld2g(0:2*nmsmax+1,0:2*nsmax+1) ! 2D representation of spectral field + integer(kind=jpim) :: jj, jms, jns + +#include "etrans_inq.h" +#include "egath_spec.h" + + if ( myproc == 1 ) then + call etrans_inq(kspec2g=nspec2g) + allocate(fldg(1,nspec2g)) + call ellips(nsmax,nmsmax,knse,kmse) + endif + + call egath_spec(PSPECG=fldg,kfgathg=kfgathg,kto=kto,kvset=kvset,PSPEC=fld) + + if ( myproc == 1 ) then + + fld2g=0. + jj=1 + do jms=0,nmsmax + do jns=0,knse(jms) + fld2g(2*jms+0,2*jns+0)=fldg(1,jj) + fld2g(2*jms+0,2*jns+1)=fldg(1,jj+1) + fld2g(2*jms+1,2*jns+0)=fldg(1,jj+2) + fld2g(2*jms+1,2*jns+1)=fldg(1,jj+3) + jj=jj+4 + enddo + enddo + + ! write to binary file + write(filename(1:1),'(a1)') fldchar + write(filename(3:5),'(i3.3)') jstep +#ifdef ACCGPU + write(filename(7:9),'(a3)') 'gpu' +#else + write(filename(7:9),'(a3)') 'cpu' +#endif + open(noutdump, file=filename, form="unformatted", access="stream") + write(noutdump) 2*nmsmax+2,2*nsmax+2 ! dimensions + write(noutdump) fld2g ! data + close(noutdump) + + ! write to screen + write(frmt(5:8),'(i4.4)') 2*(nmsmax+1) + write (*,*) fldchar,' at iteration ',jstep,':' + write (*,frmt) fld2g + call flush(6) + + deallocate(fldg) + + endif + + +end subroutine dump_spectral_field + +!=================================================================================================== + +function detect_mpirun() result(lmpi_required) + logical :: lmpi_required + integer :: ilen + integer, parameter :: nvars = 5 + character(len=32), dimension(nvars) :: cmpirun_detect + character(len=4) :: clenv_dr_hook_assert_mpi_initialized + integer :: ivar + + ! Environment variables that are set when mpirun, srun, aprun, ... are used + cmpirun_detect(1) = 'OMPI_COMM_WORLD_SIZE' ! openmpi + cmpirun_detect(2) = 'ALPS_APP_PE' ! cray pe + cmpirun_detect(3) = 'PMI_SIZE' ! intel + cmpirun_detect(4) = 'SLURM_NTASKS' ! slurm + cmpirun_detect(5) = 'ECTRANS_USE_MPI' ! forced + + lmpi_required = .false. + do ivar = 1, nvars + call get_environment_variable(name=trim(cmpirun_detect(ivar)), length=ilen) + if (ilen > 0) then + lmpi_required = .true. + exit ! break + endif + enddo +end function + +!=================================================================================================== + +! Assign GSTATS labels to the main regions of ecTrans +subroutine gstats_labels + + call gstats_label(0, ' ', 'PROGRAM - Total') + call gstats_label(1, ' ', 'SETUP_TRANS0 - Setup ecTrans') + call gstats_label(2, ' ', 'SETUP_TRANS - Setup ecTrans handle') + call gstats_label(3, ' ', 'TIME STEP - Time step') + call gstats_label(4, ' ', 'INV_TRANS - Inverse transform') + call gstats_label(5, ' ', 'DIR_TRANS - Direct transform') + call gstats_label(6, ' ', 'NORMS - Norm comp. (optional)') + call gstats_label(102, ' ', 'LTINV_CTL - Inv. Legendre transform') + call gstats_label(103, ' ', 'LTDIR_CTL - Dir. Legendre transform') + call gstats_label(106, ' ', 'FTDIR_CTL - Dir. Fourier transform') + call gstats_label(107, ' ', 'FTINV_CTL - Inv. Fourier transform') + call gstats_label(140, ' ', 'SULEG - Comp. of Leg. poly.') + call gstats_label(152, ' ', 'LTINV_CTL - M to L transposition') + call gstats_label(153, ' ', 'LTDIR_CTL - L to M transposition') + call gstats_label(157, ' ', 'FTINV_CTL - L to G transposition') + call gstats_label(158, ' ', 'FTDIR_CTL - G to L transposition') + call gstats_label(400, ' ', 'GSTATS - GSTATS itself') + +end subroutine gstats_labels + +end program ectrans_lam_benchmark + +!=================================================================================================== \ No newline at end of file diff --git a/src/trans/CMakeLists.txt b/src/trans/CMakeLists.txt index 256ad4170..f4670febf 100644 --- a/src/trans/CMakeLists.txt +++ b/src/trans/CMakeLists.txt @@ -40,6 +40,20 @@ ecbuild_list_add_pattern( LIST trans_src QUIET ) +if ( HAVE_ETRANS ) + # add LAM sources + ecbuild_list_add_pattern( LIST trans_src + GLOB + ../etrans/biper/internal/* + ../etrans/biper/external/* + ../etrans/etrans/aux/* + ../etrans/etrans/internal/* + ../etrans/etrans/external/* + QUIET + ) +endif() + + if( NOT HAVE_FFTW ) ecbuild_list_exclude_pattern( LIST trans_src REGEX tpm_fftw.F90 ) endif() @@ -56,6 +70,8 @@ foreach( prec sp dp ) SOURCES ${trans_src} PUBLIC_INCLUDES $ $ + $ + $ $ $ PUBLIC_LIBS fiat parkind_${prec} @@ -86,8 +102,22 @@ foreach( prec sp dp ) endforeach() ## Install trans interface +ecbuild_list_add_pattern( LIST trans_interface + GLOB + include/ectrans/* + QUIET + ) + +if ( HAVE_ETRANS ) + # add LAM interfaces + ecbuild_list_add_pattern( LIST trans_interface + GLOB + ../etrans/biper/include/* + ../etrans/etrans/include/* + QUIET + ) +endif() -file( GLOB trans_interface include/ectrans/* ) install( FILES ${trans_interface} DESTINATION include/ectrans From 906b165e05db8a8e13cbaeec915065574b3a02f2 Mon Sep 17 00:00:00 2001 From: Daan Degrauwe Date: Thu, 30 May 2024 15:55:24 +0200 Subject: [PATCH 05/12] cleaned installation a bit: only one library (trans) instead of separate (trans, etrans, biper); only single include directory --- src/CMakeLists.txt | 6 ++-- src/etrans/CMakeLists.txt | 38 ++++++++++++++++++++-- src/etrans/biper/CMakeLists.txt | 44 -------------------------- src/etrans/etrans/CMakeLists.txt | 54 -------------------------------- src/trans/CMakeLists.txt | 30 +----------------- 5 files changed, 40 insertions(+), 132 deletions(-) delete mode 100644 src/etrans/biper/CMakeLists.txt delete mode 100644 src/etrans/etrans/CMakeLists.txt diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index e6410ad64..81883e1d2 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -11,6 +11,6 @@ add_subdirectory( programs ) if( HAVE_TRANSI ) add_subdirectory(transi) endif() -#if( HAVE_ETRANS ) -# add_subdirectory(etrans) -#endif() \ No newline at end of file +if( HAVE_ETRANS ) + add_subdirectory(etrans) +endif() \ No newline at end of file diff --git a/src/etrans/CMakeLists.txt b/src/etrans/CMakeLists.txt index 7d8c39f0a..31cf11d7b 100644 --- a/src/etrans/CMakeLists.txt +++ b/src/etrans/CMakeLists.txt @@ -1,2 +1,36 @@ -add_subdirectory(biper) -add_subdirectory(etrans) \ No newline at end of file +# build list of sources to add to trans library +# (using CMAKE_CURRENT_SOURCE_DIR is necessary because sources are in a different directory than the target library (trans_${prec}) +ecbuild_list_add_pattern( LIST etrans_src + GLOB + ${CMAKE_CURRENT_SOURCE_DIR}/biper/internal/* + ${CMAKE_CURRENT_SOURCE_DIR}/biper/external/* + ${CMAKE_CURRENT_SOURCE_DIR}/etrans/aux/* + ${CMAKE_CURRENT_SOURCE_DIR}/etrans/internal/* + ${CMAKE_CURRENT_SOURCE_DIR}/etrans/external/* + QUIET + ) + +# dummies to be able to loop over precisions +set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) +set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) + +# loop over precisions +foreach( prec sp dp ) + if( HAVE_${prec} ) + # add sources + target_sources(trans_${prec} PRIVATE ${etrans_src}) + # add include directories + target_include_directories(trans_${prec} + PRIVATE + $ + $ + ) + endif() +endforeach() + +# install headers +file( GLOB etrans_interface biper/include/* etrans/include/*) +install( + FILES ${etrans_interface} + DESTINATION include/ectrans +) diff --git a/src/etrans/biper/CMakeLists.txt b/src/etrans/biper/CMakeLists.txt deleted file mode 100644 index 2159dc72e..000000000 --- a/src/etrans/biper/CMakeLists.txt +++ /dev/null @@ -1,44 +0,0 @@ -## Assemble sources -ecbuild_list_add_pattern( LIST biper_src - GLOB - internal/* - external/* - QUIET - ) - -set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) -set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) - -foreach( prec sp dp ) - if( HAVE_${prec} ) - - ecbuild_add_library( - TARGET biper_${prec} - LINKER_LANGUAGE Fortran - SOURCES ${biper_src} - #PUBLIC_INCLUDES #$ - #$ - #$ - #$ - PUBLIC_LIBS fiat parkind_${prec} - PRIVATE_LIBS trans_${prec} - ) - - #target_link_libraries( biper_${prec} PUBLIC fiat parkind_${prec} trans_${prec}) - - # not sure if modules should be installed: shouldn't biper be accessed through interface routines? - ectrans_target_fortran_module_directory( - TARGET biper_${prec} - MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/biper_${prec} - INSTALL_DIRECTORY module/biper_${prec} - ) - - endif() -endforeach() - -## Install biper interface -file( GLOB biper_interface include/biper/* ) -install( - FILES ${biper_interface} - DESTINATION include/ectrans -) diff --git a/src/etrans/etrans/CMakeLists.txt b/src/etrans/etrans/CMakeLists.txt deleted file mode 100644 index a29547d27..000000000 --- a/src/etrans/etrans/CMakeLists.txt +++ /dev/null @@ -1,54 +0,0 @@ - -## Assemble sources - -ecbuild_list_add_pattern( LIST etrans_src - GLOB - internal/* - external/* - aux/*.F90 - QUIET - ) - -set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) -set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) - -foreach( prec sp dp ) - if( HAVE_${prec} ) - - ecbuild_add_library( - TARGET etrans_${prec} - LINKER_LANGUAGE Fortran - SOURCES ${etrans_src} - PUBLIC_INCLUDES #$ - $ - $ - #$ - PUBLIC_LIBS fiat parkind_${prec} - PRIVATE_LIBS trans_${prec} biper_${prec} - ) - ectrans_target_fortran_module_directory( - TARGET etrans_${prec} - MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/etrans_${prec} - INSTALL_DIRECTORY module/etrans_${prec} - ) - #target_link_libraries( biper_${prec} PUBLIC fiat parkind_${prec} trans_${prec} biper_${prec}) - #if( HAVE_FFTW ) # already resolved from trans, I presume - # target_link_libraries( etrans_${prec} ${FFTW_LINK} ${FFTW_LIBRARIES} ) - # target_include_directories( etrans_${prec} PRIVATE ${FFTW_INCLUDE_DIRS} ) - # target_compile_definitions( etrans_${prec} PRIVATE WITH_FFTW ) - #endif() - #target_link_libraries( etrans_${prec} ${LAPACK_LINK} ${LAPACK_${prec}} ) # lapack isn't used by etrans - #if( HAVE_OMP ) # already resolved from trans, I presume - # target_link_libraries( etrans_${prec} PRIVATE OpenMP::OpenMP_Fortran ) - #endif() - - endif() -endforeach() - -## Install trans interface - -file( GLOB etrans_interface include/etrans/* ) -install( - FILES ${etrans_interface} - DESTINATION include/ectrans -) diff --git a/src/trans/CMakeLists.txt b/src/trans/CMakeLists.txt index f4670febf..a19490eae 100644 --- a/src/trans/CMakeLists.txt +++ b/src/trans/CMakeLists.txt @@ -40,19 +40,6 @@ ecbuild_list_add_pattern( LIST trans_src QUIET ) -if ( HAVE_ETRANS ) - # add LAM sources - ecbuild_list_add_pattern( LIST trans_src - GLOB - ../etrans/biper/internal/* - ../etrans/biper/external/* - ../etrans/etrans/aux/* - ../etrans/etrans/internal/* - ../etrans/etrans/external/* - QUIET - ) -endif() - if( NOT HAVE_FFTW ) ecbuild_list_exclude_pattern( LIST trans_src REGEX tpm_fftw.F90 ) @@ -102,22 +89,7 @@ foreach( prec sp dp ) endforeach() ## Install trans interface -ecbuild_list_add_pattern( LIST trans_interface - GLOB - include/ectrans/* - QUIET - ) - -if ( HAVE_ETRANS ) - # add LAM interfaces - ecbuild_list_add_pattern( LIST trans_interface - GLOB - ../etrans/biper/include/* - ../etrans/etrans/include/* - QUIET - ) -endif() - +file( GLOB trans_interface include/ectrans/* ) install( FILES ${trans_interface} DESTINATION include/ectrans From 8227b3dd55209984c62b8b55e454bcbae29d0af9 Mon Sep 17 00:00:00 2001 From: Daan Degrauwe Date: Mon, 10 Jun 2024 09:50:06 +0200 Subject: [PATCH 06/12] removed reference to etrans from trans/CMakeLists.txt --- src/etrans/CMakeLists.txt | 2 +- src/trans/CMakeLists.txt | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/etrans/CMakeLists.txt b/src/etrans/CMakeLists.txt index 31cf11d7b..bd88b450e 100644 --- a/src/etrans/CMakeLists.txt +++ b/src/etrans/CMakeLists.txt @@ -21,7 +21,7 @@ foreach( prec sp dp ) target_sources(trans_${prec} PRIVATE ${etrans_src}) # add include directories target_include_directories(trans_${prec} - PRIVATE + PUBLIC $ $ ) diff --git a/src/trans/CMakeLists.txt b/src/trans/CMakeLists.txt index a19490eae..0464597a5 100644 --- a/src/trans/CMakeLists.txt +++ b/src/trans/CMakeLists.txt @@ -57,8 +57,6 @@ foreach( prec sp dp ) SOURCES ${trans_src} PUBLIC_INCLUDES $ $ - $ - $ $ $ PUBLIC_LIBS fiat parkind_${prec} From d4a6aca6eeead2f3cf6b058740925ef7014f848f Mon Sep 17 00:00:00 2001 From: Daan Degrauwe Date: Tue, 3 Sep 2024 14:27:00 +0200 Subject: [PATCH 07/12] moved ellips to fiat --- src/etrans/CMakeLists.txt | 1 - src/etrans/etrans/aux/ellips.F90 | 8 --- src/etrans/etrans/aux/ellips.h | 91 ------------------------------ src/etrans/etrans/aux/ellips64.F90 | 8 --- 4 files changed, 108 deletions(-) delete mode 100644 src/etrans/etrans/aux/ellips.F90 delete mode 100644 src/etrans/etrans/aux/ellips.h delete mode 100644 src/etrans/etrans/aux/ellips64.F90 diff --git a/src/etrans/CMakeLists.txt b/src/etrans/CMakeLists.txt index bd88b450e..bb6d3c2c5 100644 --- a/src/etrans/CMakeLists.txt +++ b/src/etrans/CMakeLists.txt @@ -4,7 +4,6 @@ ecbuild_list_add_pattern( LIST etrans_src GLOB ${CMAKE_CURRENT_SOURCE_DIR}/biper/internal/* ${CMAKE_CURRENT_SOURCE_DIR}/biper/external/* - ${CMAKE_CURRENT_SOURCE_DIR}/etrans/aux/* ${CMAKE_CURRENT_SOURCE_DIR}/etrans/internal/* ${CMAKE_CURRENT_SOURCE_DIR}/etrans/external/* QUIET diff --git a/src/etrans/etrans/aux/ellips.F90 b/src/etrans/etrans/aux/ellips.F90 deleted file mode 100644 index e3af47323..000000000 --- a/src/etrans/etrans/aux/ellips.F90 +++ /dev/null @@ -1,8 +0,0 @@ -! Oct-2012 P. Marguinaud 64b LFI - -#undef JLIK -#undef _ELLIPS_ -#define JLIK JPIM -#define _ELLIPS_ ELLIPS -#include "ellips.h" - diff --git a/src/etrans/etrans/aux/ellips.h b/src/etrans/etrans/aux/ellips.h deleted file mode 100644 index 1e82d565e..000000000 --- a/src/etrans/etrans/aux/ellips.h +++ /dev/null @@ -1,91 +0,0 @@ -! Jan-2011 P. Marguinaud Interface to thread-safe FA -SUBROUTINE _ELLIPS_ (KSMAX,KMSMAX,KNTMP,KMTMP) -USE PARKIND1, ONLY : JPRB, JPRD, JPIM, JPIB -USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK -IMPLICIT NONE -! -! ***ELLIPS*** - General routine for computing elliptic truncation -! -! Purpose. -! -------- -! Computation of zonal and meridional limit wavenumbers within the ellipse -! Interface: -! ---------- -! *CALL* *ELLIPS * -! -! Explicit arguments : -! -------------------- -! -! Implicit arguments : -! -------------------- -! -! -! Method. -! ------- -! See documentation -! -! Externals. NONE. -! ---------- -! -! Reference. -! ---------- -! ARPEGE/ALADIN documentation -! -! Author. -! ------- -! G. Radnoti LACE 97/04/04 -! -! Modifications. -! -!------------------------------------------------------------- -! J.Vivoda, 99/05/19 treating NSMAX=0 and NMSMAX=0 -! O.Nuissier, 23/09/01 Change type of real (simple --> -! double precision) -! -! -INTEGER (KIND=JLIK) KSMAX, KMSMAX -INTEGER (KIND=JLIK) KNTMP(0:KMSMAX),KMTMP(0:KSMAX) -! -INTEGER (KIND=JLIK) JM, JN -! -REAL (KIND=JPRD) ZEPS, ZKN, ZKM, ZAUXIL -! -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -IF (LHOOK) CALL DR_HOOK('ELLIPS',0,ZHOOK_HANDLE) -ZEPS=1.E-10 -ZAUXIL=0. -! -! 1. Computing meridional limit wavenumbers along zonal wavenumbers -! -DO JM=1,KMSMAX-1 -ZKN = REAL(KSMAX,JPRD)/REAL(KMSMAX,JPRD)* & -& SQRT(MAX(ZAUXIL,REAL(KMSMAX**2-JM**2,JPRD))) - KNTMP(JM)=INT(ZKN+ZEPS, JLIK) -ENDDO - -IF( KMSMAX.EQ.0 )THEN - KNTMP(0)=KSMAX -ELSE - KNTMP(0)=KSMAX - KNTMP(KMSMAX)=0 -ENDIF -! -! 2. Computing zonal limit wavenumbers along meridional wavenumbers -! -DO JN=1,KSMAX-1 -ZKM = REAL(KMSMAX,JPRD)/REAL(KSMAX,JPRD)* & - & SQRT(MAX(ZAUXIL,REAL(KSMAX**2-JN**2,JPRD))) - KMTMP(JN)=INT(ZKM+ZEPS, JLIK) -ENDDO - -IF( KSMAX.EQ.0 )THEN - KMTMP(0)=KMSMAX -ELSE - KMTMP(0)=KMSMAX - KMTMP(KSMAX)=0 -ENDIF -! -IF (LHOOK) CALL DR_HOOK('ELLIPS',1,ZHOOK_HANDLE) -END - - diff --git a/src/etrans/etrans/aux/ellips64.F90 b/src/etrans/etrans/aux/ellips64.F90 deleted file mode 100644 index 083938214..000000000 --- a/src/etrans/etrans/aux/ellips64.F90 +++ /dev/null @@ -1,8 +0,0 @@ -! Oct-2012 P. Marguinaud 64b LFI - -#undef JLIK -#undef _ELLIPS_ -#define JLIK JPIB -#define _ELLIPS_ ELLIPS64 -#include "ellips.h" - From ed24fb84a49b3921ee36312cf3ab48ae225010a8 Mon Sep 17 00:00:00 2001 From: Walid CHIKHI Date: Sat, 19 Oct 2024 11:09:01 +0100 Subject: [PATCH 08/12] add ectrans python interface ectrans4py (cherry picked from commit 8d9307fa4313e21b2ef9a7e12fa6baae0e701aea) --- CMakeLists.txt | 8 + MANIFEST.in | 8 + pyproject.toml | 4 + setup.py | 32 +++ src/CMakeLists.txt | 5 +- src/ectrans4py/CMakeLists.txt | 20 ++ src/ectrans4py/__init__.py | 389 ++++++++++++++++++++++++++++++ src/ectrans4py/etrans_inq4py.F90 | 66 +++++ src/ectrans4py/gp2sp_gauss4py.F90 | 113 +++++++++ src/ectrans4py/gp2sp_lam4py.f90 | 121 ++++++++++ src/ectrans4py/sp2gp_fft1d4py.F90 | 114 +++++++++ src/ectrans4py/sp2gp_gauss4py.F90 | 123 ++++++++++ src/ectrans4py/sp2gp_lam4py.F90 | 140 +++++++++++ src/ectrans4py/spec_setup4py.F90 | 160 ++++++++++++ src/ectrans4py/trans_inq4py.F90 | 70 ++++++ 15 files changed, 1372 insertions(+), 1 deletion(-) create mode 100644 MANIFEST.in create mode 100644 pyproject.toml create mode 100644 setup.py create mode 100644 src/ectrans4py/CMakeLists.txt create mode 100644 src/ectrans4py/__init__.py create mode 100644 src/ectrans4py/etrans_inq4py.F90 create mode 100644 src/ectrans4py/gp2sp_gauss4py.F90 create mode 100644 src/ectrans4py/gp2sp_lam4py.f90 create mode 100644 src/ectrans4py/sp2gp_fft1d4py.F90 create mode 100644 src/ectrans4py/sp2gp_gauss4py.F90 create mode 100644 src/ectrans4py/sp2gp_lam4py.F90 create mode 100644 src/ectrans4py/spec_setup4py.F90 create mode 100644 src/ectrans4py/trans_inq4py.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index aec33e15b..995cd9e95 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -35,6 +35,7 @@ ecbuild_add_option( FEATURE SINGLE_PRECISION DEFAULT ON DESCRIPTION "Support for Single Precision" ) + if( HAVE_SINGLE_PRECISION ) set( single "single" ) endif() @@ -64,6 +65,13 @@ ecbuild_add_option( FEATURE ETRANS DEFAULT OFF DESCRIPTION "Include Limited-Area-Model Transforms" ) + +ecbuild_add_option( FEATURE ECTRANS4PY + DEFAULT OFF + CONDITION HAVE_ETRANS + DESCRIPTION "Compile ectrans4py interface routines for python binding w/ ctypesForFortran" ) + + ectrans_find_lapack() ### Add sources and tests diff --git a/MANIFEST.in b/MANIFEST.in new file mode 100644 index 000000000..1e1af65a5 --- /dev/null +++ b/MANIFEST.in @@ -0,0 +1,8 @@ +include AUTHORS +include CMakeLists.txt +include LICENSE +include README.md +include VERSION +recursive-include src * +recursive-include cmake * +recursive-include tests * diff --git a/pyproject.toml b/pyproject.toml new file mode 100644 index 000000000..a003b0c80 --- /dev/null +++ b/pyproject.toml @@ -0,0 +1,4 @@ +[build-system] +requires = ["setuptools", "wheel", "scikit-build"] +build-backend = "setuptools.build_meta" + diff --git a/setup.py b/setup.py new file mode 100644 index 000000000..80a8788eb --- /dev/null +++ b/setup.py @@ -0,0 +1,32 @@ +import os +import re +import ast +from skbuild import setup + +def get_version(): # remove this part + version_file = os.path.join("src", "ectrans4py", "__init__.py") + with open(version_file, "r", encoding="utf-8") as f: + content = f.read() + version_match = re.search(r"^__version__\s*=\s*['\"]([^'\"]*)['\"]", content, re.M) + if version_match: + return version_match.group(1) + raise RuntimeError("Unable to find version string.") + +version=get_version() +# ectrans4py package : +setup( + name="ectrans4py", + version=version, + packages=['ectrans4py'], + cmake_minimum_required_version="3.13", + cmake_args=[ + '-DENABLE_ETRANS=ON', + '-DENABLE_ECTRANS4PY=ON', + '-DENABLE_SINGLE_PRECISION=OFF', + '-DENABLE_OMP=OFF', + ], + package_dir={"": "src"}, + cmake_install_dir="src/ectrans4py", + setup_requires=["scikit-build", "setuptools"], + install_requires=["numpy", "ctypesforfortran==1.1.3"], +) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 81883e1d2..706806cd8 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -13,4 +13,7 @@ if( HAVE_TRANSI ) endif() if( HAVE_ETRANS ) add_subdirectory(etrans) -endif() \ No newline at end of file +endif() +if(HAVE_ECTRANS4PY) + add_subdirectory(ectrans4py) +endif() diff --git a/src/ectrans4py/CMakeLists.txt b/src/ectrans4py/CMakeLists.txt new file mode 100644 index 000000000..857d7d609 --- /dev/null +++ b/src/ectrans4py/CMakeLists.txt @@ -0,0 +1,20 @@ +if(HAVE_ETRANS) + # (using CMAKE_CURRENT_SOURCE_DIR is necessary because sources are in a different directory than the target library (trans_${prec})) + ecbuild_list_add_pattern( + LIST ectrans4py_src + GLOB ${CMAKE_CURRENT_SOURCE_DIR}/*.F90 + QUIET + ) + + set(HAVE_dp ${HAVE_DOUBLE_PRECISION}) + set(prec dp) + + if(HAVE_${prec}) + # Add sources + target_sources(trans_${prec} PRIVATE ${ectrans4py_src}) + endif() + +else() + ecbuild_critical("To activate the ectrans Python interface, you must enable the ETRANS option.") +endif() + diff --git a/src/ectrans4py/__init__.py b/src/ectrans4py/__init__.py new file mode 100644 index 000000000..5591f3465 --- /dev/null +++ b/src/ectrans4py/__init__.py @@ -0,0 +1,389 @@ +#!/usr/bin/env python3 +# -*- coding: utf-8 -*- +# Copyright (c) Météo France (2014-) +# This software is governed by the CeCILL-C license under French law. +# http://www.cecill.info +""" +ialsptrans4py: + +Contains the interface to spectral transforms from the IAL/ecTrans. +Note that this is temporary between the former package arpifs4py and a direct python interface to ecTrans. + +Actual .so library should be in one of the preinstalled paths or in a directory specified via LD_LIBRARY_PATH +""" + +from __future__ import print_function, absolute_import, unicode_literals, division + +import os +import numpy as np +import ctypesForFortran +from ctypesForFortran import addReturnCode, treatReturnCode, IN, OUT + + + +__version__ = "2.0.1" + +# Shared objects library +######################## +shared_objects_library = os.environ.get('IALSPTRANS4PY_SO', None) +if shared_objects_library is None or not os.path.exists(shared_objects_library): + # not specified or path does not exist : find in known locations + so_basename = "libtrans_dp.so" # local name in the directory + LD_LIBRARY_PATH = [p for p in os.environ.get('LD_LIBRARY_PATH', '').split(':') if p != ''] + potential_locations = LD_LIBRARY_PATH + [ + os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib'), # FIXEME : but requiere changes in CMakeLists.txt + os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib64'), # force one libdir directory name ! +# "/home/common/epygram/public/EPyGrAM/libs4py", # CNRM +# "/home/gmap/mrpe/mary/public/EPyGrAM/libs4py", # belenos/taranis +# "/home/acrd/public/EPyGrAM/libs4py", # ECMWF's Atos aa-ad + ] + for _libs4py_dir in potential_locations: + shared_objects_library = os.path.join(_libs4py_dir, so_basename) + if os.path.exists(shared_objects_library): + break + else: + shared_objects_library = None + if shared_objects_library is None: + msg = ' '.join(["'{}' was not found in any of potential locations: {}.", + "You can specify a different location using env var LD_LIBRARY_PATH", + "or specify a precise full path using env var IALSPTRANS4PY_SO."]).format( + so_filename, str(potential_locations)) + raise FileNotFoundError(msg) +else: + so_basename = os.path.basename(shared_objects_library) +ctypesFF, handle = ctypesForFortran.ctypesForFortranFactory(shared_objects_library) + +# Initialization +################ + +def init_env(omp_num_threads=None, + no_mpi=False): + """ + Set adequate environment for the inner libraries. + + :param int omp_num_threads: sets OMP_NUM_THREADS + :param bool no_mpi: environment variable DR_HOOK_NOT_MPI set to 1 + """ + # because arpifs library is compiled with MPI & openMP + if omp_num_threads is not None: + os.environ['OMP_NUM_THREADS'] = str(omp_num_threads) + if no_mpi: + os.environ['DR_HOOK_NOT_MPI'] = '1' + +# Transforms interfaces +####################### + +@treatReturnCode +@ctypesFF() +@addReturnCode +def etrans_inq4py(KSIZEI, KSIZEJ, + KPHYSICALSIZEI, KPHYSICALSIZEJ, + KTRUNCX, KTRUNCY, + KNUMMAXRESOL, + PDELATX, PDELATY): + """ + Simplified wrapper to ETRANS_INQ. + + Args:\n + 1,2) KSIZEI, KSIZEJ: size of grid-point field (with extension zone) + 3,4) KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field + 5,6) KTRUNCX, KTRUNCY: troncatures + 7) KNUMMAXRESOL: maximum number of troncatures handled + 8,9) PDELTAX, PDELTAY: resolution along x,y axis + + Returns:\n + 1) KGPTOT: number of gridpoints + 2) KSPEC: number of spectral coefficients + """ + return ([KSIZEI, KSIZEJ, + KPHYSICALSIZEI, KPHYSICALSIZEJ, + KTRUNCX, KTRUNCY, + KNUMMAXRESOL, + PDELATX, PDELATY], + [(np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.float64, None, IN), + (np.float64, None, IN), + (np.int64, None, OUT), + (np.int64, None, OUT)], + None) + + +@treatReturnCode +@ctypesFF() +@addReturnCode +def trans_inq4py(KSIZEJ, KTRUNC, KSLOEN, KLOEN, KNUMMAXRESOL): + """ + Simplified wrapper to TRANS_INQ. + + Args:\n + 1) KSIZEJ: number of latitudes in grid-point space + 2) KTRUNC: troncature + 3) KSLOEN: Size of KLOEN + 4) KLOEN: number of points on each latitude row + 5) KNUMMAXRESOL: maximum number of troncatures handled + + Returns:\n + 1) KGPTOT: number of gridpoints + 2) KSPEC: number of spectral coefficients + 3) KNMENG: cut-off zonal wavenumber + """ + return ([KSIZEJ, KTRUNC, KSLOEN, KLOEN, KNUMMAXRESOL], + [(np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, (KSLOEN,), IN), + (np.int64, None, IN), + (np.int64, None, OUT), + (np.int64, None, OUT), + (np.int64, (KSLOEN,), OUT)], + None) + + +@treatReturnCode +@ctypesFF() +@addReturnCode +def sp2gp_lam4py(KSIZEI, KSIZEJ, + KPHYSICALSIZEI, KPHYSICALSIZEJ, + KTRUNCX, KTRUNCY, + KNUMMAXRESOL, + KSIZE, + LGRADIENT, + LREORDER, + PDELTAX, PDELTAY, + PSPEC): + """ + Transform spectral coefficients into grid-point values. + + Args:\n + 1,2) KSIZEI, KSIZEJ: size of grid-point field (with extension zone) + 3,4) KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field + 5,6) KTRUNCX, KTRUNCY: troncatures + 7) KNUMMAXRESOL: maximum number of troncatures handled + 8) KSIZE: size of PSPEC + 9) LGRADIENT: gradient computation + 10) LREORDER: reorder spectral coefficients or not + 11,12) PDELTAX,PDELTAY: resolution along x,y axis + 13) PSPEC: spectral coefficient array + + Returns:\n + 1) PGPT: grid-point field + 2) PGPTM: N-S derivative if LGRADIENT + 3) PGPTL: E-W derivative if LGRADIENT + """ + return ([KSIZEI, KSIZEJ, + KPHYSICALSIZEI, KPHYSICALSIZEJ, + KTRUNCX, KTRUNCY, + KNUMMAXRESOL, + KSIZE, + LGRADIENT, + LREORDER, + PDELTAX, PDELTAY, + PSPEC], + [(np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (bool, None, IN), + (bool, None, IN), + (np.float64, None, IN), + (np.float64, None, IN), + (np.float64, (KSIZE,), IN), + (np.float64, (KSIZEI * KSIZEJ,), OUT), + (np.float64, (KSIZEI * KSIZEJ,), OUT), + (np.float64, (KSIZEI * KSIZEJ,), OUT)], + None) + + +@treatReturnCode +@ctypesFF() +@addReturnCode +def gp2sp_lam4py(KSIZE, + KSIZEI, KSIZEJ, + KPHYSICALSIZEI, KPHYSICALSIZEJ, + KTRUNCX, KTRUNCY, + KNUMMAXRESOL, + PDELTAX, PDELTAY, + LREORDER, + PGPT): + """ + Transform grid point values into spectral coefficients. + + Args:\n + 1) KSIZE: size of spectral field + 2,3) KSIZEI, KSIZEJ: size of grid-point field (with extension zone) + 4,5) KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field + 6,7) KTRUNCX, KTRUNCY: troncatures + 8) KNUMMAXRESOL: maximum number of troncatures handled + 9,10) PDELTAX, PDELTAY: resolution along x,y axis + 11) LREORDER: reorder spectral coefficients or not + 12) PGPT: grid-point field + + Returns:\n + 1) PSPEC: spectral coefficient array + """ + return ([KSIZE, + KSIZEI, KSIZEJ, + KPHYSICALSIZEI, KPHYSICALSIZEJ, + KTRUNCX, KTRUNCY, + KNUMMAXRESOL, + PDELTAX, PDELTAY, + LREORDER, + PGPT], + [(np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.float64, None, IN), + (np.float64, None, IN), + (bool, None, IN), + (np.float64, (KSIZEI * KSIZEJ,), IN), + (np.float64, (KSIZE,), OUT)], + None) + + +@treatReturnCode +@ctypesFF() +@addReturnCode +def sp2gp_gauss4py(KSIZEJ, + KTRUNC, + KNUMMAXRESOL, + KGPTOT, + KSLOEN, + KLOEN, + KSIZE, + LGRADIENT, + LREORDER, + PSPEC): + """ + Transform spectral coefficients into grid-point values. + + Args:\n + 1) KSIZEJ: Number of latitudes + 2) KTRUNC: troncature + 3) KNUMMAXRESOL: maximum number of troncatures handled + 4) KGPTOT: number of grid-points + 5) KSLOEN: Size of KLOEN + 6) KLOEN: + 7) KSIZE: Size of PSPEC + 8) LGRADIENT: compute derivatives + 9) LREORDER: reorder spectral coefficients or not + 10) PSPEC: spectral coefficient array + + Returns:\n + 1) PGPT: grid-point field + 2) PGPTM: N-S derivative if LGRADIENT + 3) PGPTL: E-W derivative if LGRADIENT + """ + return ([KSIZEJ, + KTRUNC, + KNUMMAXRESOL, + KGPTOT, + KSLOEN, + KLOEN, + KSIZE, + LGRADIENT, + LREORDER, + PSPEC], + [(np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, (KSLOEN,), IN), + (np.int64, None, IN), + (bool, None, IN), + (bool, None, IN), + (np.float64, (KSIZE,), IN), + (np.float64, (KGPTOT,), OUT), + (np.float64, (KGPTOT,), OUT), + (np.float64, (KGPTOT,), OUT)], + None) + + +@treatReturnCode +@ctypesFF() +@addReturnCode +def gp2sp_gauss4py(KSPEC, + KSIZEJ, + KTRUNC, + KNUMMAXRESOL, + KSLOEN, + KLOEN, + KSIZE, + LREORDER, + PGPT): + """ + Transform grid-point values into spectral coefficients. + + Args:\n + 1) KSPEC: size of spectral coefficients array + 2) KSIZEJ: Number of latitudes + 3) KTRUNC: troncature + 4) KNUMMAXRESOL: maximum number of troncatures handled + 5) KSLOEN: Size of KLOEN + 6) KLOEN + 7) KSIZE: Size of PGPT + 8) LREORDER: reorder spectral coefficients or not + 9) PGPT: grid-point field + + Returns:\n + 1) PSPEC: spectral coefficient array + """ + return ([KSPEC, + KSIZEJ, + KTRUNC, + KNUMMAXRESOL, + KSLOEN, + KLOEN, + KSIZE, + LREORDER, + PGPT], + [(np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, None, IN), + (np.int64, (KSLOEN,), IN), + (np.int64, None, IN), + (bool, None, IN), + (np.float64, (KSIZE,), IN), + (np.float64, (KSPEC,), OUT)], + None) + + +@ctypesFF() +def sp2gp_fft1d4py(KSIZES, KTRUNC, PSPEC, KSIZEG): + """ + Transform spectral coefficients into grid-point values, + for a 1D array (vertical section academic model) + + Args:\n + 1) KSIZES size of PSPEC + 2) KTRUNC: troncature + 3) PSPEC: spectral coefficient array + 4) KSIZEG: size of grid-point field (with extension zone) + + Returns:\n + 1) PGPT: grid-point field + """ + return ([KSIZES, KTRUNC, PSPEC, KSIZEG], + [(np.int64, None, IN), + (np.int64, None, IN), + (np.float64, (KSIZES,), IN), + (np.int64, None, IN), + (np.float64, (KSIZEG,), OUT)], + None) diff --git a/src/ectrans4py/etrans_inq4py.F90 b/src/ectrans4py/etrans_inq4py.F90 new file mode 100644 index 000000000..7f2113fba --- /dev/null +++ b/src/ectrans4py/etrans_inq4py.F90 @@ -0,0 +1,66 @@ +SUBROUTINE ETRANS_INQ4PY(KRETURNCODE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & + &KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELTAX, PDELTAY, & + &KGPTOT, KSPEC) +! ** PURPOSE +! Simplified wrapper to ETRANS_INQ +! +! ** DUMMY ARGUMENTS +! KSIZEI, KSIZEJ: size of grid-point field (with extension zone) +! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field +! KTRUNCX, KTRUNCY: troncatures +! KNUMMAXRESOL: maximum number of troncatures handled +! PDELTAX: x resolution +! PDELTAY: y resolution +! KGPTOT: number of gridpoints +! KSPEC: number of spectral coefficients +! +! ** AUTHOR +! 9 April 2014, S. Riette +! +! ** MODIFICATIONS +! 6 Jan., S. Riette: PDELTAX and PDELTAY added +! +! I. Dummy arguments declaration +IMPLICIT NONE +INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE +INTEGER(KIND=8), INTENT(IN) :: KSIZEI, KSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KTRUNCX, KTRUNCY +INTEGER(KIND=8), INTENT(IN) :: KNUMMAXRESOL +REAL(KIND=8), INTENT(IN) :: PDELTAX +REAL(KIND=8), INTENT(IN) :: PDELTAY +INTEGER(KIND=8), INTENT(OUT) :: KGPTOT +INTEGER(KIND=8), INTENT(OUT) :: KSPEC +! +! II. Local variables declaration +INTEGER, DIMENSION(0:KTRUNCX) :: IESM0 +INTEGER :: ISIZEI, ISIZEJ, & + & IPHYSICALSIZEI, IPHYSICALSIZEJ, & + & ITRUNCX, ITRUNCY, & + & INUMMAXRESOL +LOGICAL :: LLSTOP +INTEGER :: IIDENTRESOL +INTEGER, DIMENSION(1) :: ILOEN +INTEGER :: IGPTOT, ISPEC + +#include "etrans_inq.h" + +ISIZEI=KSIZEI +ISIZEJ=KSIZEJ +IPHYSICALSIZEI=KPHYSICALSIZEI +IPHYSICALSIZEJ=KPHYSICALSIZEJ +ITRUNCX=KTRUNCX +ITRUNCY=KTRUNCY +INUMMAXRESOL=KNUMMAXRESOL + +! III. Setup +CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & + &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .TRUE., 1, & + &PDELTAX, PDELTAY, IIDENTRESOL, LLSTOP) +IF (.NOT. LLSTOP) THEN + CALL ETRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KESM0=IESM0) + KGPTOT=IGPTOT + KSPEC=ISPEC +ENDIF +! +END SUBROUTINE ETRANS_INQ4PY diff --git a/src/ectrans4py/gp2sp_gauss4py.F90 b/src/ectrans4py/gp2sp_gauss4py.F90 new file mode 100644 index 000000000..76fff02c8 --- /dev/null +++ b/src/ectrans4py/gp2sp_gauss4py.F90 @@ -0,0 +1,113 @@ +SUBROUTINE GP2SP_GAUSS4PY(KRETURNCODE, KSPEC, KSIZEJ, KTRUNC, KNUMMAXRESOL, KSLOEN, KLOEN, KSIZE, LREORDER, PGPT, PSPEC) +! ** PURPOSE +! Transform spectral coefficients into grid-point values +! +! ** DUMMY ARGUMENTS +! KRETURNCODE: error code +! KSPEC: size of spectral coefficients array +! KSIZEJ: Number of latitudes +! KTRUNC: troncature +! KNUMMAXRESOL: maximum number of troncatures handled +! KSLOEN: Size ok KLOEN +! KLOEN +! KSIZE: Size of PGPT +! LREORDER: switch to reorder spectral coefficients or not +! PGPT: grid-point field +! PSPEC: spectral coefficient array +! +! ** AUTHOR +! 9 April 2014, S. Riette +! +! ** MODIFICATIONS +! 6 Jan. 2016, S. Riette: w_spec_setup interface modified +! March, 2016, A.Mary: LREORDER +! +! I. Dummy arguments declaration +USE PARKIND1, ONLY : JPRB +IMPLICIT NONE +INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE +INTEGER(KIND=8), INTENT(IN) :: KSPEC +INTEGER(KIND=8), INTENT(IN) :: KSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KTRUNC +INTEGER(KIND=8), INTENT(IN) :: KNUMMAXRESOL +INTEGER(KIND=8), INTENT(IN) :: KSLOEN +INTEGER(KIND=8), DIMENSION(KSLOEN), INTENT(IN) :: KLOEN +INTEGER(KIND=8), INTENT(IN) :: KSIZE +LOGICAL, INTENT(IN) :: LREORDER +REAL(KIND=8), DIMENSION(KSIZE), INTENT(IN) :: PGPT +REAL(KIND=8), DIMENSION(KSPEC), INTENT(OUT) :: PSPEC +! +! II. Local variables declaration +INTEGER, DIMENSION(SIZE(KLOEN)) :: ILOEN +INTEGER :: ISIZEI, ISIZEJ, & + & IPHYSICALSIZEI, IPHYSICALSIZEJ, & + & ITRUNCX, ITRUNCY, & + & INUMMAXRESOL +LOGICAL :: LLSTOP +INTEGER :: IIDENTRESOL +INTEGER :: JI, JM, JN +INTEGER, DIMENSION(0:KTRUNC) :: NASM0 +REAL(KIND=JPRB), DIMENSION(1, SIZE(PGPT)) :: ZSPBUF !size over-evaluated +REAL(KIND=JPRB), DIMENSION(SIZE(PGPT), 1, 1) :: ZGPBUF +REAL(KIND=8) :: ZDELTAX, ZDELTAY + +#include "trans_inq.h" +#include "dir_trans.h" +KRETURNCODE=0 +ILOEN(:)=KLOEN(:) +ISIZEI=0 +ISIZEJ=KSIZEJ +IPHYSICALSIZEI=0 +IPHYSICALSIZEJ=0 +ITRUNCX=KTRUNC +ITRUNCY=0 +INUMMAXRESOL=KNUMMAXRESOL +! +! III. Setup +ZDELTAX=0. +ZDELTAY=0. +CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & + &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .FALSE., SIZE(ILOEN), & + &ZDELTAX, ZDELTAY, IIDENTRESOL, LLSTOP) +! +! IV. Transformation +! IV.a Shape of coefficient array +IF (.NOT. LLSTOP) THEN + JI=1 + DO JN=0, KTRUNC + NASM0(JN)=JI + JI=JI+1+JN+(JN+1) + ENDDO +ENDIF + +! IV.b Direct transform +IF (.NOT. LLSTOP) THEN + ZGPBUF(:,1,1)=REAL(PGPT(:),KIND=JPRB) + CALL DIR_TRANS(PSPSCALAR=ZSPBUF(:,:), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) +ENDIF + +! IV.c Reordering +IF (LREORDER) THEN + IF(.NOT. LLSTOP) THEN + PSPEC(:)=0. + JI=1 + DO JM=0, KTRUNC + DO JN=JM, KTRUNC + PSPEC(NASM0(JN)+JM)=REAL(ZSPBUF(1,JI),KIND=8) + JI=JI+1 + IF(JM/=0) THEN + PSPEC(NASM0(JN)-JM)=REAL(ZSPBUF(1,JI),KIND=8) + ENDIF + JI=JI+1 + ENDDO + ENDDO + IF(JI-1/=KSPEC) THEN + PRINT*, "Internal error in GP2SP_GAUSS4PY (spectral reordering)" + KRETURNCODE=-999 + ENDIF + ENDIF +ELSE + PSPEC(1:KSPEC) = REAL(ZSPBUF(1,1:KSPEC),KIND=8) +ENDIF + +END SUBROUTINE GP2SP_GAUSS4PY diff --git a/src/ectrans4py/gp2sp_lam4py.f90 b/src/ectrans4py/gp2sp_lam4py.f90 new file mode 100644 index 000000000..036a4674b --- /dev/null +++ b/src/ectrans4py/gp2sp_lam4py.f90 @@ -0,0 +1,121 @@ +SUBROUTINE GP2SP_LAM4PY(KRETURNCODE, KSIZE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & + &KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELTAX, PDELTAY, LREORDER, PGPT, PSPEC) +! ** PURPOSE +! Transform grid point values into spectral coefficients +! +! ** DUMMY ARGUMENTS +! KRETURNCODE: error code +! KSIZE: size of spectral field +! KSIZEI, KSIZEJ: size of grid-point field (with extension zone) +! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field +! KTRUNCX, KTRUNCY: troncatures +! KNUMMAXRESOL: maximum number of troncatures handled +! PDELTAX: x resolution +! PDELTAY: y resolution +! LREORDER: switch to reorder spectral coefficients or not +! PGPT: grid-point field +! PSPEC: spectral coefficient array +! +! ** AUTHOR +! 9 April 2014, S. Riette +! +! ** MODIFICATIONS +! 6 Jan., S. Riette: PDELTAX and PDELTAY added +! March, 2016, A.Mary: LREORDER +! +! I. Dummy arguments declaration +USE PARKIND1, ONLY : JPRB +IMPLICIT NONE +INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE +INTEGER(KIND=8), INTENT(IN) :: KSIZE, KSIZEI, KSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KTRUNCX, KTRUNCY +INTEGER(KIND=8), INTENT(IN) :: KNUMMAXRESOL +REAL(KIND=8), INTENT(IN) :: PDELTAX +REAL(KIND=8), INTENT(IN) :: PDELTAY +LOGICAL, INTENT(IN) :: LREORDER +REAL(KIND=8), DIMENSION(KSIZEI*KSIZEJ), INTENT(IN) :: PGPT +REAL(KIND=8), DIMENSION(KSIZE), INTENT(OUT) :: PSPEC +! +! II. Local variables declaration +INTEGER, DIMENSION(0:KTRUNCX) :: IESM0 +INTEGER :: IGPTOT, ISPEC +INTEGER, DIMENSION(0:KTRUNCY) :: ISPECINI, ISPECEND +REAL(KIND=JPRB), DIMENSION(1, KSIZEI*KSIZEJ) :: ZSPBUF !size over-evaluated +REAL(KIND=JPRB), DIMENSION(KSIZEI*KSIZEJ, 1, 1) :: ZGPBUF +INTEGER :: JI, JM, JN, IIDENTRESOL +LOGICAL :: LLSTOP +INTEGER :: ISIZEI, ISIZEJ, & + & IPHYSICALSIZEI, IPHYSICALSIZEJ, & + & ITRUNCX, ITRUNCY, & + & INUMMAXRESOL +INTEGER, DIMENSION(1) :: ILOEN + +#include "edir_trans.h" +#include "etrans_inq.h" + +KRETURNCODE=0 +LLSTOP=.FALSE. +ISIZEI=KSIZEI +ISIZEJ=KSIZEJ +IPHYSICALSIZEI=KPHYSICALSIZEI +IPHYSICALSIZEJ=KPHYSICALSIZEJ +ITRUNCX=KTRUNCX +ITRUNCY=KTRUNCY +INUMMAXRESOL=KNUMMAXRESOL + +! III. Setup +CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & + &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .TRUE., 1, & + &PDELTAX, PDELTAY, IIDENTRESOL, LLSTOP) + +! IV. Transformation + +! IV.a Shape of coefficient array +!IGPTOT is the total number of points in grid-point space +!ISPEC is the number of spectral coefficients +!IESM0(m) is the index of spectral coefficient (m,0) in model +!ISPECINI(n) is the index of the first of the 4 spectral coefficient (0,n) in FA file +!ISPECEND(n) is the index of the last of the last 4 spectral coefficients (:,n) in FA file +IF (.NOT. LLSTOP) THEN + CALL ETRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KESM0=IESM0) + JI=1 + DO JN=0, ITRUNCY + ISPECINI(JN)=(JI-1)*4+1 + JI=JI+COUNT(IESM0(1:ITRUNCX)-IESM0(0:ITRUNCX-1)>JN*4) + IF (ISPEC-IESM0(ITRUNCX)>JN*4) JI=JI+1 + ISPECEND(JN)=(JI-1)*4 + ENDDO +ENDIF + +! III.b transform +IF (.NOT. LLSTOP) THEN + ZGPBUF(:,1,1)=REAL(PGPT(:),KIND=JPRB) + CALL EDIR_TRANS(PSPSCALAR=ZSPBUF(:,:), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) +ENDIF + +! III.c Reordering +! reorder Aladin : file ordering = coeffs per blocks of m, 4 reals per coeff +! Aladin array ordering = coeffs per blocks of n, 4 reals per coeff +IF (LREORDER) THEN + IF (.NOT. LLSTOP) THEN + JI=1 + PSPEC(:)=0. + DO JM=0,ITRUNCX*4+4,4 + DO JN=0,ITRUNCY + IF (ISPECINI(JN)+JM+3<=ISPECEND(JN)) THEN + PSPEC(ISPECINI(JN)+JM:ISPECINI(JN)+JM+3) = REAL(ZSPBUF(1,JI:JI+3),KIND=8) + JI=JI+4 + ENDIF + ENDDO + ENDDO + IF(JI/=ISPEC+1) THEN + PRINT*, "Internal error in GP2SP_LAM4PY (spectral reordering)" + KRETURNCODE=-999 + ENDIF + ENDIF +ELSE + PSPEC(1:KSIZE) = REAL(ZSPBUF(1,1:KSIZE),KIND=8) +ENDIF + +END SUBROUTINE GP2SP_LAM4PY diff --git a/src/ectrans4py/sp2gp_fft1d4py.F90 b/src/ectrans4py/sp2gp_fft1d4py.F90 new file mode 100644 index 000000000..060f14f4d --- /dev/null +++ b/src/ectrans4py/sp2gp_fft1d4py.F90 @@ -0,0 +1,114 @@ +SUBROUTINE SP2GP_FFT1D4PY(KSIZES, KTRUNC, PSPEC, KSIZEG, PGPT) +! ** PURPOSE +! Transform spectral coefficients into grid-point values, +! for a 1D array (vertical section academic model) +! +! ** DUMMY ARGUMENTS +! KSIZES size of PSPEC +! KTRUNC: troncature +! PSPEC: spectral coefficient array +! KSIZEG: size of grid-point field (with extension zone) +! PGPT: grid-point field +! +! ** AUTHOR +! 26 March 2015, A. Mary, from utilities/pinuts/module/fa_datas_mod.F90 +! +! ** MODIFICATIONS +! +! I. Dummy arguments declaration +IMPLICIT NONE + +INTEGER(KIND=8), INTENT(IN) :: KSIZES +INTEGER(KIND=8), INTENT(IN) :: KTRUNC +REAL(KIND=8), DIMENSION(KSIZES), INTENT(IN) :: PSPEC +INTEGER(KIND=8), INTENT(IN) :: KSIZEG +REAL(KIND=8), DIMENSION(KSIZEG), INTENT(OUT) :: PGPT + +INTEGER(KIND=8) :: NSEFRE, NFTM, NDGLSUR +REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: SP2, TRIGSE +INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: NFAXE +INTEGER(KIND=8), PARAMETER :: NZERO=0 + +NDGLSUR = KSIZEG+MOD(KSIZEG,2)+2 +NFTM = 2*(KTRUNC+1) +ALLOCATE(SP2(NDGLSUR*NFTM)) +SP2 = 0.0 +SP2 = CONVRT2FFT(PSPEC,NZERO,KTRUNC,NDGLSUR) +ALLOCATE(NFAXE(1:10)) +ALLOCATE(TRIGSE(1:KSIZEG)) +CALL SET99(TRIGSE,NFAXE,KSIZEG) +CALL FFT992(SP2(1:KSIZEG), TRIGSE, NFAXE, 1, NDGLSUR, KSIZEG, 1, 1) +DEALLOCATE(TRIGSE) +DEALLOCATE(NFAXE) +PGPT(:) = SP2(1:KSIZEG) + +CONTAINS + +! from utilities/pinuts/module/fa_datas_mod.F90 +! and utilities/pinuts/module/array_lib_mod.F90 + +FUNCTION CONVRT2FFT(IN,X,Y,N) RESULT(OU) +REAL(KIND=8),DIMENSION(:),INTENT(IN) :: IN +INTEGER(KIND=8),INTENT(IN) :: X, Y, N +REAL(KIND=8),DIMENSION(N*2*(X+1)) :: OU + +INTEGER(KIND=8),DIMENSION(2*(X+1),(N/2)) :: MINQ +INTEGER(KIND=8),DIMENSION((N/2),2*(X+1)) :: TMINQ +REAL(KIND=8),DIMENSION(2*(X+1),(N/2)) :: OMINQ, EMINQ +REAL(KIND=8),DIMENSION((N/2),2*(X+1)) :: TOMINQ, TEMINQ +REAL(KIND=8),DIMENSION(N*(X+1)) :: OINI, EINI +REAL(KIND=8), PARAMETER :: ZZERO=0.0 + +CALL SPLIT_ODEV(IN,OINI,EINI) +MINQ = MASQ(X,Y,N) +OMINQ = UNPACK(OINI,MINQ == 1,ZZERO) +TOMINQ = TRANSPOSE(OMINQ) +EMINQ = UNPACK(EINI,MINQ == 1,ZZERO) +TEMINQ = TRANSPOSE(EMINQ) +TMINQ = 1 +OINI = PACK(TOMINQ,TMINQ > 0) +EINI = PACK(TEMINQ,TMINQ > 0) +OU = MIX_ODEV(OINI,EINI) +END FUNCTION CONVRT2FFT + +FUNCTION MASQ(X,Y,N) RESULT(T) +INTEGER(KIND=8),INTENT(IN) :: X, Y, N +INTEGER(KIND=8),DIMENSION(1:2*(X+1),1:(N/2)) :: T + +INTEGER(KIND=8) :: I, J +INTEGER(KIND=8),DIMENSION(0:X) :: KM +INTEGER(KIND=8),DIMENSION(0:Y) :: KN +CALL ELLIPS64(X,Y,KN,KM) +T = 0 +DO I=0,Y + DO J=0,2*KN(I)+1 + T(J+1,I+1)=1 + END DO +END DO +END FUNCTION MASQ + +FUNCTION MIX_ODEV(TO,TE) RESULT(T) +REAL(KIND=8),DIMENSION(:),INTENT(IN) :: TO,TE +REAL(KIND=8),DIMENSION(SIZE(TO)+SIZE(TE)) :: T + +INTEGER(KIND=8) :: I + +DO I=1,(SIZE(TO)+SIZE(TE))/2 + T((2*I)-1)=TE(I) + T(2*I)=TO(I) +END DO +END FUNCTION MIX_ODEV + +SUBROUTINE SPLIT_ODEV(T,TO,TE) +REAL(KIND=8),DIMENSION(:),INTENT(IN) :: T +REAL(KIND=8),DIMENSION(SIZE(T)/2),INTENT(OUT) :: TO,TE + +INTEGER(KIND=8) :: I + +DO I=1,SIZE(T)/2 + TO(I)=T(2*I) + TE(I)=T((2*I)-1) +END DO +END SUBROUTINE SPLIT_ODEV + +END SUBROUTINE SP2GP_FFT1D4PY \ No newline at end of file diff --git a/src/ectrans4py/sp2gp_gauss4py.F90 b/src/ectrans4py/sp2gp_gauss4py.F90 new file mode 100644 index 000000000..61186f53f --- /dev/null +++ b/src/ectrans4py/sp2gp_gauss4py.F90 @@ -0,0 +1,123 @@ +SUBROUTINE SP2GP_GAUSS4PY(KRETURNCODE, KSIZEJ, KTRUNC, KNUMMAXRESOL, KGPTOT, KSLOEN, KLOEN, KSIZE, & + & LGRADIENT, LREORDER, PSPEC, PGPT, PGPTM, PGPTL) +! ** PURPOSE +! Transform spectral coefficients into grid-point values +! +! ** DUMMY ARGUMENTS +! KSIZEJ: Number of latitudes +! KTRUNC: troncature +! KNUMMAXRESOL: maximum number of troncatures handled +! KGPTOT: number of grid-points +! KSLOEN: Size of KLOEN +! KLOEN: +! KSIZE: Size of PSPEC +! LREORDER: switch to reorder spectral coefficients or not +! LGRADIENT: switch to compute or not gradient +! PSPEC: spectral coefficient array +! PGPT: grid-point field +! PGPTM: N-S derivative if LGRADIENT +! PGPTL: E-W derivative if LGRADIENT +! +! ** AUTHOR +! 9 April 2014, S. Riette +! +! ** MODIFICATIONS +! 6 Jan., S. Riette: w_spec_setup interface modified +! March, 2016, A.Mary: LREORDER +! Sept., 2016, A.Mary: LGRADIENT +! +! I. Dummy arguments declaration +USE PARKIND1, ONLY : JPRB +IMPLICIT NONE +INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE +INTEGER(KIND=8), INTENT(IN) :: KSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KTRUNC +INTEGER(KIND=8), INTENT(IN) :: KNUMMAXRESOL +INTEGER(KIND=8), INTENT(IN) :: KGPTOT +INTEGER(KIND=8), INTENT(IN) :: KSLOEN +INTEGER(KIND=8), DIMENSION(KSLOEN), INTENT(IN) :: KLOEN +INTEGER(KIND=8), INTENT(IN) :: KSIZE +LOGICAL, INTENT(IN) :: LGRADIENT +LOGICAL, INTENT(IN) :: LREORDER +REAL(KIND=8), DIMENSION(KSIZE), INTENT(IN) :: PSPEC +REAL(KIND=8), DIMENSION(KGPTOT), INTENT(OUT) :: PGPT +REAL(KIND=8), DIMENSION(KGPTOT), INTENT(OUT) :: PGPTM +REAL(KIND=8), DIMENSION(KGPTOT), INTENT(OUT) :: PGPTL +! +! II. Local variables declaration +INTEGER, DIMENSION(SIZE(KLOEN)) :: ILOEN +INTEGER :: ISIZEI, ISIZEJ, & + & IPHYSICALSIZEI, IPHYSICALSIZEJ, & + & ITRUNCX, ITRUNCY, & + & INUMMAXRESOL +LOGICAL :: LLSTOP +INTEGER :: IIDENTRESOL +INTEGER :: JI, JM, JN +INTEGER, DIMENSION(0:KTRUNC) :: NASM0 +REAL(KIND=8), DIMENSION(1, KSIZE) :: ZSPBUF +REAL(KIND=JPRB), DIMENSION(KGPTOT, 3, 1) :: ZGPBUF +REAL(KIND=8) :: ZDELTAX, ZDELTAY +#include "trans_inq.h" +#include "inv_trans.h" + +ILOEN(:)=KLOEN(:) +ISIZEI=0 +ISIZEJ=KSIZEJ +IPHYSICALSIZEI=0 +IPHYSICALSIZEJ=0 +ITRUNCX=KTRUNC +ITRUNCY=0 +INUMMAXRESOL=KNUMMAXRESOL +! +! III. Setup +ZDELTAX=0. +ZDELTAY=0. +CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & + &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .FALSE., SIZE(ILOEN), & + &ZDELTAX, ZDELTAY, IIDENTRESOL, LLSTOP) +! +! IV. Transformation +IF (LREORDER) THEN + ! IV.a Shape of coefficient array + IF (.NOT. LLSTOP) THEN + JI=1 + DO JN=0, KTRUNC + NASM0(JN)=JI + JI=JI+1+JN+(JN+1) + ENDDO + ENDIF + + ! IV.b Reordering + IF(.NOT. LLSTOP) THEN + ZSPBUF(1,:)=0. + JI=1 + DO JM=0, KTRUNC + DO JN=JM, KTRUNC + ZSPBUF(1,JI)=PSPEC(NASM0(JN)+JM) + JI=JI+1 + IF(JM==0) THEN + ZSPBUF(1,JI)=0 + ELSE + ZSPBUF(1,JI)=PSPEC(NASM0(JN)-JM) + ENDIF + JI=JI+1 + ENDDO + ENDDO + ENDIF +ELSE + ZSPBUF(1,:) = PSPEC(:) +ENDIF + +! IV.c Inverse transform +IF (.NOT. LLSTOP) THEN + IF (.NOT. LGRADIENT) THEN + CALL INV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) + PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) + ELSE + CALL INV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL, LDSCDERS=.TRUE.) + PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) + PGPTM(:)=REAL(ZGPBUF(:,2,1),KIND=8) + PGPTL(:)=REAL(ZGPBUF(:,3,1),KIND=8) + ENDIF +ENDIF +END SUBROUTINE SP2GP_GAUSS4PY diff --git a/src/ectrans4py/sp2gp_lam4py.F90 b/src/ectrans4py/sp2gp_lam4py.F90 new file mode 100644 index 000000000..17657966f --- /dev/null +++ b/src/ectrans4py/sp2gp_lam4py.F90 @@ -0,0 +1,140 @@ +SUBROUTINE SP2GP_LAM4PY(KRETURNCODE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & + &KTRUNCX, KTRUNCY, KNUMMAXRESOL, KSIZE, LGRADIENT, LREORDER, PDELTAX, PDELTAY, & + &PSPEC, PGPT, PGPTM, PGPTL) +! ** PURPOSE +! Transform spectral coefficients into grid-point values +! +! ** DUMMY ARGUMENTS +! KRETURNCODE: error code +! KSIZEI, KSIZEJ: size of grid-point field (with extension zone) +! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field +! KTRUNCX, KTRUNCY: troncatures +! KNUMMAXRESOL: maximum number of troncatures handled +! KSIZE: size of PSPEC +! LREORDER: switch to reorder spectral coefficients or not +! LGRADIENT: switch to compute or not gradient +! PDELTAX: x resolution +! PDELTAY: y resolution +! PSPEC: spectral coefficient array +! PGPT: grid-point field +! PGPTM: N-S derivative if LGRADIENT +! PGPTL: E-W derivative if LGRADIENT +! +! ** AUTHOR +! 9 April 2014, S. Riette +! +! ** MODIFICATIONS +! 5 Jan., S. Riette: PDELTAX, PDELTAY, LGRADIENT, PGPTM and PGPTL added +! March, 2016, A.Mary: LREORDER +! +! I. Dummy arguments declaration +USE PARKIND1, ONLY : JPRB +IMPLICIT NONE +INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE +INTEGER(KIND=8), INTENT(IN) :: KSIZEI, KSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KTRUNCX, KTRUNCY +INTEGER(KIND=8), INTENT(IN) :: KNUMMAXRESOL +INTEGER(KIND=8), INTENT(IN) :: KSIZE +LOGICAL, INTENT(IN) :: LGRADIENT +LOGICAL, INTENT(IN) :: LREORDER +REAL(KIND=8), INTENT(IN) :: PDELTAX +REAL(KIND=8), INTENT(IN) :: PDELTAY +REAL(KIND=8), DIMENSION(KSIZE), INTENT(IN) :: PSPEC +REAL(KIND=8), DIMENSION(KSIZEI*KSIZEJ), INTENT(OUT) :: PGPT +REAL(KIND=8), DIMENSION(KSIZEI*KSIZEJ), INTENT(OUT) :: PGPTM +REAL(KIND=8), DIMENSION(KSIZEI*KSIZEJ), INTENT(OUT) :: PGPTL +! +! II. Local variables declaration +INTEGER, DIMENSION(0:KTRUNCX) :: IESM0 +INTEGER :: IGPTOT, ISPEC +INTEGER, DIMENSION(0:KTRUNCY) :: ISPECINI, ISPECEND +REAL(KIND=8), DIMENSION(1, KSIZE) :: ZSPBUF +REAL(KIND=JPRB), DIMENSION(KSIZEI*KSIZEJ, 3, 1) :: ZGPBUF +INTEGER :: JI, JM, JN, IINDEX, IIDENTRESOL +LOGICAL :: LLSTOP +INTEGER :: ISIZEI, ISIZEJ, & + & IPHYSICALSIZEI, IPHYSICALSIZEJ, & + & ITRUNCX, ITRUNCY, & + & INUMMAXRESOL +INTEGER, DIMENSION(1) :: ILOEN + +#include "einv_trans.h" +#include "etrans_inq.h" + +KRETURNCODE=0 +LLSTOP=.FALSE. +ISIZEI=KSIZEI +ISIZEJ=KSIZEJ +IPHYSICALSIZEI=KPHYSICALSIZEI +IPHYSICALSIZEJ=KPHYSICALSIZEJ +ITRUNCX=KTRUNCX +ITRUNCY=KTRUNCY +INUMMAXRESOL=KNUMMAXRESOL +ILOEN(:)=0 + +! III. Setup +CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & + &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .TRUE., 1, & + &PDELTAX, PDELTAY, IIDENTRESOL, LLSTOP) + +! IV. Transformation + +! IV.a Shape of coefficient array +!IGPTOT is the total number of points in grid-point space +!ISPEC is the number of spectral coefficients +!IESM0(m) is the index of spectral coefficient (m,0) in model +!ISPECINI(n) is the index of the first of the 4 spectral coefficient (0,n) in FA file +!ISPECEND(n) is the index of the last of the last 4 spectral coefficients (:,n) in FA file +IF (.NOT. LLSTOP) THEN + CALL ETRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KESM0=IESM0) + JI=1 + DO JN=0, ITRUNCY + ISPECINI(JN)=(JI-1)*4+1 + JI=JI+COUNT(IESM0(1:ITRUNCX)-IESM0(0:ITRUNCX-1)>JN*4) + IF (ISPEC-IESM0(ITRUNCX)>JN*4) JI=JI+1 + ISPECEND(JN)=(JI-1)*4 + ENDDO +ENDIF + +! III.b Reordering +! reorder Aladin : file ordering = coeffs per blocks of m, 4 reals per coeff +! Aladin array ordering = coeffs per blocks of n, 4 reals per coeff +IF (LREORDER) THEN + IF (.NOT. LLSTOP) THEN + ZSPBUF(:,:)=0. + JI=1 + DO JM=0,ITRUNCX+1 + DO JN=0,ITRUNCY + IF (ISPECINI(JN)+JM*4+3<=ISPECEND(JN)) THEN + DO IINDEX=ISPECINI(JN)+JM*4, ISPECINI(JN)+JM*4+3 + ZSPBUF(1,JI)=PSPEC(IINDEX) + JI=JI+1 + ENDDO + ENDIF + ENDDO + ENDDO + IF (JI/=ISPEC+1) THEN + PRINT*, "Internal error in SP2GP_LAM4PY (spectral reordering)" + KRETURNCODE=-999 + LLSTOP=.TRUE. + ENDIF + ENDIF +ELSE + ZSPBUF(1,:) = PSPEC(:) +ENDIF + +! III.c Inverse transform +IF (.NOT. LLSTOP) THEN + IF (.NOT. LGRADIENT) THEN + CALL EINV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) + PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) + ELSE + CALL EINV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL, LDSCDERS=.TRUE.) + PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) + PGPTM(:)=REAL(ZGPBUF(:,2,1),KIND=8) + PGPTL(:)=REAL(ZGPBUF(:,3,1),KIND=8) + ENDIF +ENDIF + +END SUBROUTINE SP2GP_LAM4PY diff --git a/src/ectrans4py/spec_setup4py.F90 b/src/ectrans4py/spec_setup4py.F90 new file mode 100644 index 000000000..644962e3a --- /dev/null +++ b/src/ectrans4py/spec_setup4py.F90 @@ -0,0 +1,160 @@ +SUBROUTINE SPEC_SETUP4PY(KRETURNCODE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & + &KTRUNCX, KTRUNCY, KNUMMAXRESOL, KLOEN, LDLAM, & + &KSIZEKLOEN, PDELTAX, PDELTAY, & + &KIDENTRESOL, LDSTOP) +! ** PURPOSE +! Setup spectral transform for LAM and global +! +! ** DUMMY ARGUMENTS +! KRETURNCODE: error code +! KSIZEI, KSIZEJ: size of grid-point field (with extension zone for LAM), put max size for KSIZEI in global +! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field for LAM (put 0 for global) +! KTRUNCX, KTRUNCY: troncatures for LAM (only KTRUNCX is used for global, put 0 for KTRUNCY) +! KNUMMAXRESOL: maximum number of troncatures handled +! KLOEN: number of points on each latitude row +! KSIZEKLOEN: size of KLOEN array +! PDELTAX: x resolution +! PDELTAY: y resolution +! LDLAM: LAM (.TRUE.) or global (.FALSE.) +! KIDENTRESOL: identification of resolution +! LDSTOP: exception raised? +! +! ** AUTHOR +! 9 April 2014, S. Riette +! +! ** MODIFICATIONS +! 6 Jan 2016, S. Riette: PDELTAX and PDELTAY added +! 31 Jan 2019 R. El Khatib fix for single precision compilation +! +! I. Dummy arguments declaration +USE PARKIND1, ONLY : JPRB +IMPLICIT NONE +INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE +INTEGER, INTENT(IN) :: KSIZEI, KSIZEJ +INTEGER, INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ +INTEGER, INTENT(IN) :: KTRUNCX, KTRUNCY +INTEGER, INTENT(IN) :: KNUMMAXRESOL +INTEGER, DIMENSION(KSIZEKLOEN), INTENT(IN) :: KLOEN +LOGICAL, INTENT(IN) :: LDLAM +INTEGER, INTENT(IN) :: KSIZEKLOEN +REAL(KIND=8), INTENT(IN) :: PDELTAX +REAL(KIND=8), INTENT(IN) :: PDELTAY +INTEGER, INTENT(OUT) :: KIDENTRESOL +LOGICAL, INTENT(OUT) :: LDSTOP +! +! II. Local variables declaration +INTEGER, DIMENSION(2*KSIZEJ) :: ILOEN +INTEGER :: JI +LOGICAL, SAVE :: LLFIRSTCALL=.TRUE. +LOGICAL :: LLNEWRESOL +INTEGER, SAVE :: INBRESOL=0 +INTEGER(KIND=8) :: ICODEILOEN +INTEGER, SAVE :: INUMMAXRESOLSAVE=-1 +INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: ITRUNCXSAVE, ITRUNCYSAVE, & + IPHYSICALSIZEISAVE, & + IPHYSICALSIZEJSAVE, & + ISIZEISAVE, ISIZEJSAVE, & + IIDENTRESOLSAVE +INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE, SAVE :: ILOENSAVE +REAL(KIND=8), DIMENSION(:), ALLOCATABLE, SAVE :: ZDELTAXSAVE, & + ZDELTAYSAVE +REAL(KIND=8) :: ZEXWN, ZEYWN + +#include "setup_trans0.h" +#include "esetup_trans.h" +#include "setup_trans.h" + +KRETURNCODE=0 +LDSTOP=.FALSE. +! III. Setup + +! III.a Setup LAM and global spectral transform - all resolutions +! Maximum number of resolution is set now and cannot be change anymore +IF (LLFIRSTCALL) THEN + !This code is called only once, whatever is the number of resolutions + CALL SETUP_TRANS0(KPRINTLEV=0, LDMPOFF=.TRUE., KMAX_RESOL=KNUMMAXRESOL) + ALLOCATE(ITRUNCXSAVE(KNUMMAXRESOL)) + ALLOCATE(ITRUNCYSAVE(KNUMMAXRESOL)) + ALLOCATE(IPHYSICALSIZEISAVE(KNUMMAXRESOL)) + ALLOCATE(IPHYSICALSIZEJSAVE(KNUMMAXRESOL)) + ALLOCATE(ISIZEJSAVE(KNUMMAXRESOL)) + ALLOCATE(ISIZEISAVE(KNUMMAXRESOL)) + ALLOCATE(ILOENSAVE(KNUMMAXRESOL)) + ALLOCATE(IIDENTRESOLSAVE(KNUMMAXRESOL)) + ALLOCATE(ZDELTAXSAVE(KNUMMAXRESOL)) + ALLOCATE(ZDELTAYSAVE(KNUMMAXRESOL)) + ITRUNCXSAVE=-1 + ITRUNCYSAVE=-1 + IPHYSICALSIZEISAVE=-1 + IPHYSICALSIZEJSAVE=-1 + ISIZEJSAVE=-1 + ISIZEISAVE=-1 + ILOENSAVE=-1 + IIDENTRESOLSAVE=-1 + ZDELTAXSAVE=-1. + ZDELTAXSAVE=-1. + LLFIRSTCALL=.FALSE. + INUMMAXRESOLSAVE=KNUMMAXRESOL +ENDIF +! +! III.b Is-it a new resolution? +LLNEWRESOL=.TRUE. +IF(LDLAM) THEN + ILOEN(:)=KSIZEI +ELSE + ILOEN(:)=0 + ILOEN(1:MIN(SIZE(ILOEN),SIZE(KLOEN)))=KLOEN(1:MIN(SIZE(ILOEN),SIZE(KLOEN))) +ENDIF +ICODEILOEN=0 +DO JI=1, SIZE(ILOEN) + ICODEILOEN=ICODEILOEN+ILOEN(JI)*JI**4 +ENDDO +DO JI=1, INBRESOL + IF (KTRUNCX==ITRUNCXSAVE(JI) .AND. KTRUNCY==ITRUNCYSAVE(JI) .AND. & + &KPHYSICALSIZEI==IPHYSICALSIZEISAVE(JI) .AND. & + &KPHYSICALSIZEJ==IPHYSICALSIZEJSAVE(JI) .AND. & + &KSIZEJ==ISIZEJSAVE(JI) .AND. KSIZEI==ISIZEISAVE(JI) .AND. & + &ICODEILOEN==ILOENSAVE(JI) .AND. & + &PDELTAX==ZDELTAXSAVE(JI) .AND. PDELTAY==ZDELTAYSAVE(JI)) THEN + KIDENTRESOL=IIDENTRESOLSAVE(JI) + LLNEWRESOL=.FALSE. + ENDIF +ENDDO +IF(LLNEWRESOL) THEN + INBRESOL=INBRESOL+1 + IF(INBRESOL>INUMMAXRESOLSAVE) THEN + PRINT*, "Error in SPEC_SETUP4PY : Maximum number of resolution is exceeded." + KRETURNCODE=-999 + LDSTOP=.TRUE. + ENDIF +ENDIF +! +! III.c Setup LAM or global spectral transform - once by resolution +IF(LLNEWRESOL .AND. .NOT. LDSTOP) THEN + ! The following code is exectuded once for each resolution + ITRUNCXSAVE(INBRESOL)=KTRUNCX + ITRUNCYSAVE(INBRESOL)=KTRUNCY + IPHYSICALSIZEISAVE(INBRESOL)=KPHYSICALSIZEI + IPHYSICALSIZEJSAVE(INBRESOL)=KPHYSICALSIZEJ + ISIZEISAVE(INBRESOL)=KSIZEI + ISIZEJSAVE(INBRESOL)=KSIZEJ + ILOENSAVE(INBRESOL)=ICODEILOEN + ZDELTAXSAVE(INBRESOL)=PDELTAX + ZDELTAYSAVE(INBRESOL)=PDELTAY + IF(LDLAM) THEN + ZEXWN=2*3.141592653589797/(KSIZEI*PDELTAX) + ZEYWN=2*3.141592653589797/(KSIZEJ*PDELTAY) + CALL ESETUP_TRANS(KMSMAX=ITRUNCXSAVE(INBRESOL), KSMAX=ITRUNCYSAVE(INBRESOL), & + &KDGUX=IPHYSICALSIZEJSAVE(INBRESOL), & + &KDGL=ISIZEJSAVE(INBRESOL), KLOEN=ILOEN(:), KRESOL=IIDENTRESOLSAVE(INBRESOL), & + &PEXWN=REAL(ZEXWN,KIND=JPRB), PEYWN=REAL(ZEYWN,KIND=JPRB)) + ELSE + PRINT*, "Setup spectral transform" + CALL SETUP_TRANS(KSMAX=ITRUNCXSAVE(INBRESOL), KDGL=ISIZEJSAVE(INBRESOL), & + &KLOEN=ILOEN(1:ISIZEJSAVE(INBRESOL)), KRESOL=IIDENTRESOLSAVE(INBRESOL)) + PRINT*, "End Setup spectral transform" + ENDIF + KIDENTRESOL=IIDENTRESOLSAVE(INBRESOL) +ENDIF +END SUBROUTINE SPEC_SETUP4PY + diff --git a/src/ectrans4py/trans_inq4py.F90 b/src/ectrans4py/trans_inq4py.F90 new file mode 100644 index 000000000..f989ef175 --- /dev/null +++ b/src/ectrans4py/trans_inq4py.F90 @@ -0,0 +1,70 @@ +SUBROUTINE TRANS_INQ4PY(KRETURNCODE, KSIZEJ, KTRUNC, KSLOEN, KLOEN, KNUMMAXRESOL, & + &KGPTOT, KSPEC, KNMENG) +! ** PURPOSE +! Simplified wrapper to TRANS_INQ +! +! ** DUMMY ARGUMENTS +! KSIZEJ: number of latitudes in grid-point space +! KTRUNC: troncature +! KSLOEN: Size of KLOEN +! KLOEN: number of points on each latitude row +! KNUMMAXRESOL: maximum number of troncatures handled +! KGPTOT: number of gridpoints +! KSPEC: number of spectral coefficients +! KNMENG: cut-off zonal wavenumber +! +! ** AUTHOR +! 9 April 2014, S. Riette +! +! ** MODIFICATIONS +! 6 Jan., S. Riette: w_spec_setup interfaced modified +! +! I. Dummy arguments declaration +IMPLICIT NONE +INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE +INTEGER(KIND=8), INTENT(IN) :: KSIZEJ +INTEGER(KIND=8), INTENT(IN) :: KTRUNC +INTEGER(KIND=8), INTENT(IN) :: KSLOEN +INTEGER(KIND=8), DIMENSION(KSLOEN), INTENT(IN) :: KLOEN +INTEGER(KIND=8), INTENT(IN) :: KNUMMAXRESOL +INTEGER(KIND=8), INTENT(OUT) :: KGPTOT +INTEGER(KIND=8), INTENT(OUT) :: KSPEC +INTEGER(KIND=8), DIMENSION(KSLOEN), INTENT(OUT) :: KNMENG +! +! II. Local variables declaration +INTEGER, DIMENSION(SIZE(KLOEN)) :: ILOEN +INTEGER :: ISIZEI, ISIZEJ, & + & IPHYSICALSIZEI, IPHYSICALSIZEJ, & + & ITRUNCX, ITRUNCY, & + & INUMMAXRESOL +LOGICAL :: LLSTOP +INTEGER :: IIDENTRESOL +INTEGER :: IGPTOT, ISPEC +INTEGER, DIMENSION(SIZE(KLOEN)) :: INMENG +REAL(KIND=8) :: ZDELTAX, ZDELTAY +#include "trans_inq.h" + +ILOEN(:)=KLOEN(:) +ISIZEI=0 +ISIZEJ=KSIZEJ +IPHYSICALSIZEI=0 +IPHYSICALSIZEJ=0 +ITRUNCX=KTRUNC +ITRUNCY=0 +INUMMAXRESOL=KNUMMAXRESOL +INMENG(:)=KNMENG(:) +! +! III. Setup +ZDELTAX=0. +ZDELTAY=0. +CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & + &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .FALSE., SIZE(ILOEN), & + &ZDELTAX, ZDELTAY, IIDENTRESOL, LLSTOP) +IF (.NOT. LLSTOP) THEN + CALL TRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KNMENG=INMENG) + KGPTOT=IGPTOT + KSPEC=ISPEC + KNMENG=INMENG +ENDIF +! +END SUBROUTINE TRANS_INQ4PY From bf27e6152a44fea645e031bd4278b5f4c99e52a1 Mon Sep 17 00:00:00 2001 From: Alexandre MARY Date: Wed, 30 Oct 2024 09:07:04 +0000 Subject: [PATCH 09/12] ectrans4py version is same as ectrans --- CMakeLists.txt | 1 - setup.py | 18 +++++------------- 2 files changed, 5 insertions(+), 14 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 995cd9e95..9145e25af 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -35,7 +35,6 @@ ecbuild_add_option( FEATURE SINGLE_PRECISION DEFAULT ON DESCRIPTION "Support for Single Precision" ) - if( HAVE_SINGLE_PRECISION ) set( single "single" ) endif() diff --git a/setup.py b/setup.py index 80a8788eb..e164c53ce 100644 --- a/setup.py +++ b/setup.py @@ -1,26 +1,18 @@ import os -import re import ast from skbuild import setup -def get_version(): # remove this part - version_file = os.path.join("src", "ectrans4py", "__init__.py") - with open(version_file, "r", encoding="utf-8") as f: - content = f.read() - version_match = re.search(r"^__version__\s*=\s*['\"]([^'\"]*)['\"]", content, re.M) - if version_match: - return version_match.group(1) - raise RuntimeError("Unable to find version string.") +_version_file = os.path.join(os.path.dirname(os.path.abspath(__file__)), "VERSION") +with open(_version_file, "r") as f: + __version__ = f.read().strip() -version=get_version() -# ectrans4py package : setup( name="ectrans4py", - version=version, + version=__version__, packages=['ectrans4py'], cmake_minimum_required_version="3.13", cmake_args=[ - '-DENABLE_ETRANS=ON', + '-DENABLE_ETRANS=ON', '-DENABLE_ECTRANS4PY=ON', '-DENABLE_SINGLE_PRECISION=OFF', '-DENABLE_OMP=OFF', From 96ba538ce46b9ba93aafe4d68ad5a320f9e7dddf Mon Sep 17 00:00:00 2001 From: Alexandre MARY Date: Wed, 30 Oct 2024 13:51:56 +0100 Subject: [PATCH 10/12] cleaner python package --- pyproject.toml | 7 +++++ src/ectrans4py/__init__.py | 61 ++++++++++++++++---------------------- 2 files changed, 33 insertions(+), 35 deletions(-) diff --git a/pyproject.toml b/pyproject.toml index a003b0c80..6ff8e42ee 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -2,3 +2,10 @@ requires = ["setuptools", "wheel", "scikit-build"] build-backend = "setuptools.build_meta" +[project] +name = "ectrans4py" +dynamic = ["version"] +dependencies=["numpy", "ctypesForFortran<2.0.0"] + +[tool.setuptools.dynamic] +version = {attr = "ectrans4py.__version__"} diff --git a/src/ectrans4py/__init__.py b/src/ectrans4py/__init__.py index 5591f3465..093f8d2bf 100644 --- a/src/ectrans4py/__init__.py +++ b/src/ectrans4py/__init__.py @@ -1,74 +1,65 @@ #!/usr/bin/env python3 # -*- coding: utf-8 -*- -# Copyright (c) Météo France (2014-) -# This software is governed by the CeCILL-C license under French law. -# http://www.cecill.info """ -ialsptrans4py: +ectrans4py: -Contains the interface to spectral transforms from the IAL/ecTrans. -Note that this is temporary between the former package arpifs4py and a direct python interface to ecTrans. - -Actual .so library should be in one of the preinstalled paths or in a directory specified via LD_LIBRARY_PATH +A Python interface to spectral transforms from ecTrans, using cTypesForFortran for the Fortran/Python binding. """ from __future__ import print_function, absolute_import, unicode_literals, division import os +import resource import numpy as np import ctypesForFortran from ctypesForFortran import addReturnCode, treatReturnCode, IN, OUT +__version__ = "1.2.0" -__version__ = "2.0.1" # Shared objects library ######################## -shared_objects_library = os.environ.get('IALSPTRANS4PY_SO', None) -if shared_objects_library is None or not os.path.exists(shared_objects_library): - # not specified or path does not exist : find in known locations - so_basename = "libtrans_dp.so" # local name in the directory - LD_LIBRARY_PATH = [p for p in os.environ.get('LD_LIBRARY_PATH', '').split(':') if p != ''] - potential_locations = LD_LIBRARY_PATH + [ - os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib'), # FIXEME : but requiere changes in CMakeLists.txt - os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib64'), # force one libdir directory name ! -# "/home/common/epygram/public/EPyGrAM/libs4py", # CNRM -# "/home/gmap/mrpe/mary/public/EPyGrAM/libs4py", # belenos/taranis -# "/home/acrd/public/EPyGrAM/libs4py", # ECMWF's Atos aa-ad +so_basename = "libtrans_dp.so" # local name of library in the directory +LD_LIBRARY_PATH = [p for p in os.environ.get('LD_LIBRARY_PATH', '').split(':') if p != ''] +lpath = LD_LIBRARY_PATH + [ + os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib'), + os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib64'), ] - for _libs4py_dir in potential_locations: - shared_objects_library = os.path.join(_libs4py_dir, so_basename) - if os.path.exists(shared_objects_library): - break - else: - shared_objects_library = None - if shared_objects_library is None: - msg = ' '.join(["'{}' was not found in any of potential locations: {}.", - "You can specify a different location using env var LD_LIBRARY_PATH", - "or specify a precise full path using env var IALSPTRANS4PY_SO."]).format( - so_filename, str(potential_locations)) - raise FileNotFoundError(msg) -else: - so_basename = os.path.basename(shared_objects_library) +for d in lpath: + shared_objects_library = os.path.join(d, so_basename) + if os.path.exists(shared_objects_library): + break + else: + shared_objects_library = None +if shared_objects_library is None: + msg = ' '.join(["'{}' was not found in any of potential locations: {}.", + "You can specify a different location using env var LD_LIBRARY_PATH"]) + msg = msg.format(so_basename, str(lpath)) + raise FileNotFoundError(msg) ctypesFF, handle = ctypesForFortran.ctypesForFortranFactory(shared_objects_library) # Initialization ################ def init_env(omp_num_threads=None, - no_mpi=False): + no_mpi=True, + unlimited_stack=True, + ): """ Set adequate environment for the inner libraries. :param int omp_num_threads: sets OMP_NUM_THREADS :param bool no_mpi: environment variable DR_HOOK_NOT_MPI set to 1 + :param unlimited_stack: equivalent to 'ulimit -s unlimited' """ # because arpifs library is compiled with MPI & openMP if omp_num_threads is not None: os.environ['OMP_NUM_THREADS'] = str(omp_num_threads) if no_mpi: os.environ['DR_HOOK_NOT_MPI'] = '1' + if unlimited_stack: + resource.setrlimit(resource.RLIMIT_STACK, (resource.RLIM_INFINITY, resource.RLIM_INFINITY)) # Transforms interfaces ####################### From 36f345d2896d67865f8a58d493c8ed3ce215e804 Mon Sep 17 00:00:00 2001 From: Alexandre MARY Date: Wed, 30 Oct 2024 13:52:29 +0100 Subject: [PATCH 11/12] Optional PROGRAMS feature --- CMakeLists.txt | 5 ++++- setup.py | 1 + src/CMakeLists.txt | 4 +++- 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9145e25af..8921e5543 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -64,7 +64,10 @@ ecbuild_add_option( FEATURE ETRANS DEFAULT OFF DESCRIPTION "Include Limited-Area-Model Transforms" ) - +ecbuild_add_option( FEATURE PROGRAMS + DEFAULT ON + DESCRIPTION "Build src/programs" ) + ecbuild_add_option( FEATURE ECTRANS4PY DEFAULT OFF CONDITION HAVE_ETRANS diff --git a/setup.py b/setup.py index e164c53ce..3fc19a53e 100644 --- a/setup.py +++ b/setup.py @@ -15,6 +15,7 @@ '-DENABLE_ETRANS=ON', '-DENABLE_ECTRANS4PY=ON', '-DENABLE_SINGLE_PRECISION=OFF', + '-DENABLE_PROGRAMS=OFF', '-DENABLE_OMP=OFF', ], package_dir={"": "src"}, diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 706806cd8..963d00090 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -7,7 +7,9 @@ # nor does it submit to any jurisdiction. add_subdirectory( trans ) -add_subdirectory( programs ) +if(HAVE_PROGRAMS) + add_subdirectory( programs ) +endif() if( HAVE_TRANSI ) add_subdirectory(transi) endif() From 00cdb6eacbd13c05c0278906f5b9ceb1adc5f68d Mon Sep 17 00:00:00 2001 From: Alexandre MARY Date: Wed, 30 Oct 2024 17:58:22 +0100 Subject: [PATCH 12/12] Label 1.2.50 = 1.2.0+@CY50 --- VERSION | 2 +- src/ectrans4py/__init__.py | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/VERSION b/VERSION index 26aaba0e8..99188f0c6 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.2.0 +1.2.50 diff --git a/src/ectrans4py/__init__.py b/src/ectrans4py/__init__.py index 093f8d2bf..e28b7acf8 100644 --- a/src/ectrans4py/__init__.py +++ b/src/ectrans4py/__init__.py @@ -15,7 +15,7 @@ from ctypesForFortran import addReturnCode, treatReturnCode, IN, OUT -__version__ = "1.2.0" +__version__ = "1.2.50" # Shared objects library