Line |
Branch |
Exec |
Source |
1 |
|
|
MODULE SULEG_MOD |
2 |
|
|
CONTAINS |
3 |
|
✗ |
SUBROUTINE SULEG |
4 |
|
|
|
5 |
|
|
USE PARKIND1 ,ONLY : JPIM ,JPRB |
6 |
|
|
USE PARKIND2 ,ONLY : JPRH |
7 |
|
|
|
8 |
|
|
USE TPM_GEN |
9 |
|
|
USE TPM_DIM |
10 |
|
|
USE TPM_CONSTANTS |
11 |
|
|
USE TPM_DISTR |
12 |
|
|
USE TPM_FIELDS |
13 |
|
|
|
14 |
|
|
!USE SUGAW_MOD |
15 |
|
|
USE SUPOL_MOD |
16 |
|
|
USE SUTRLE_MOD |
17 |
|
|
|
18 |
|
|
|
19 |
|
|
|
20 |
|
|
IMPLICIT NONE |
21 |
|
|
|
22 |
|
|
|
23 |
|
|
! ------------------------------------------------------------------ |
24 |
|
|
REAL(KIND=JPRB),ALLOCATABLE :: ZPNMG(:,:) |
25 |
|
|
|
26 |
|
✗ |
REAL(KIND=JPRH) :: DLRMU(R%NDGL) |
27 |
|
✗ |
REAL(KIND=JPRH) :: DLC(0:R%NTMAX+1,0:R%NTMAX+1) |
28 |
|
✗ |
REAL(KIND=JPRH) :: DLD(0:R%NTMAX+1,0:R%NTMAX+1) |
29 |
|
✗ |
REAL(KIND=JPRH) :: DLE(0:R%NTMAX+1,0:R%NTMAX+1) |
30 |
|
✗ |
REAL(KIND=JPRH) :: DLA(0:R%NTMAX+1),DLB(0:R%NTMAX+1),DLF(0:R%NTMAX+1) |
31 |
|
✗ |
REAL(KIND=JPRH) :: DLG(0:R%NTMAX+1),DLH(0:R%NTMAX+1),DLI(0:R%NTMAX+1) |
32 |
|
✗ |
REAL(KIND=JPRH) :: DLPOL(0:R%NTMAX+1,0:R%NTMAX+1) |
33 |
|
|
! ------------------------------------------------------------------ |
34 |
|
|
|
35 |
|
|
INTEGER(KIND=JPIM), PARAMETER :: JPKS=KIND(ZPNMG) |
36 |
|
|
INTEGER(KIND=JPIM), PARAMETER :: JPKD=KIND(DLG) |
37 |
|
|
|
38 |
|
|
! ------------------------------------------------------------------ |
39 |
|
|
REAL(KIND=JPRH) :: DA,DC,DD,DE |
40 |
|
|
INTEGER(KIND=JPIM) :: KKN, KKM |
41 |
|
|
|
42 |
|
|
! LOCAL |
43 |
|
|
INTEGER(KIND=JPIM) :: IGLLOC, INM, IM , ICOUNT,& |
44 |
|
|
&JGL, JM, JMLOC, JN, JNM |
45 |
|
|
|
46 |
|
|
|
47 |
|
|
LOGICAL :: LLP1,LLP2 |
48 |
|
|
|
49 |
|
|
|
50 |
|
|
DC(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPKD)*REAL(KKN+KKM-1,JPKD)& |
51 |
|
|
&*REAL(KKN+KKM-3,JPKD))& |
52 |
|
|
&/ (REAL(2*KKN-3,JPKD)*REAL(KKN+KKM,JPKD)& |
53 |
|
|
&*REAL(KKN+KKM-2,JPKD)) ) |
54 |
|
|
DD(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPKD)*REAL(KKN+KKM-1,JPKD)& |
55 |
|
|
&*REAL(KKN-KKM+1,JPKD))& |
56 |
|
|
&/ (REAL(2*KKN-1,JPKD)*REAL(KKN+KKM,JPKD)& |
57 |
|
|
&*REAL(KKN+KKM-2,JPKD)) ) |
58 |
|
|
DE(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPKD)*REAL(KKN-KKM,JPKD))& |
59 |
|
|
&/ (REAL(2*KKN-1,JPKD)*REAL(KKN+KKM,JPKD)) ) |
60 |
|
|
DA(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPKD)*REAL(KKN-KKM,JPKD)& |
61 |
|
|
&*REAL(KKN+KKM,JPKD))& |
62 |
|
|
&/ REAL(2*KKN-1,JPKD) ) |
63 |
|
|
|
64 |
|
|
! ------------------------------------------------------------------ |
65 |
|
✗ |
ALLOCATE(ZPNMG(R%NSPOLEG,D%NLEI3D)) |
66 |
|
|
|
67 |
|
|
!* 0. Some initializations. |
68 |
|
|
! --------------------- |
69 |
|
|
|
70 |
|
✗ |
LLP1 = NPRINTLEV>0 |
71 |
|
|
LLP2 = NPRINTLEV>1 |
72 |
|
✗ |
IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SULEG ===' |
73 |
|
|
|
74 |
|
|
!CALL GSTATS(140,0) !MPL 4.12.08 |
75 |
|
✗ |
ALLOCATE(F%RPNM(R%NLEI3,D%NSPOLEGL)) |
76 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%RPNM ',SIZE(F%RPNM),SHAPE(F%RPNM) |
77 |
|
✗ |
ALLOCATE(F%RMU(R%NDGL)) |
78 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%RMU ',SIZE(F%RMU ),SHAPE(F%RMU ) |
79 |
|
✗ |
ALLOCATE(F%RW(R%NDGL)) |
80 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%RW ',SIZE(F%RW ),SHAPE(F%RW ) |
81 |
|
✗ |
ALLOCATE(F%R1MU2(R%NDGL)) |
82 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%R1MU2 ',SIZE(F%R1MU2),SHAPE(F%R1MU2 ) |
83 |
|
✗ |
ALLOCATE(F%RACTHE(R%NDGL)) |
84 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%RACTHE ',SIZE(F%RACTHE),SHAPE(F%RACTHE ) |
85 |
|
|
|
86 |
|
|
!CALL GSTATS(1801,0) ! MPL 4.12.08 |
87 |
|
✗ |
DO JNM=1,D%NSPOLEGL |
88 |
|
✗ |
F%RPNM(R%NLEI3,JNM) = 0.0_JPRB |
89 |
|
|
ENDDO |
90 |
|
|
!CALL GSTATS(1801,1) ! MPL 4.12.08 |
91 |
|
|
|
92 |
|
|
! ------------------------------------------------------------------ |
93 |
|
|
|
94 |
|
|
!* 3.1 Gaussian latitudes and weights |
95 |
|
|
!CALL SUGAW(R%NDGL,F%RMU,DLRMU,F%RW) |
96 |
|
|
|
97 |
|
|
!* 3.2 Computes related arrays |
98 |
|
|
|
99 |
|
✗ |
DO JGL=1,R%NDGL |
100 |
|
✗ |
F%R1MU2(JGL) = REAL(1.0_JPRB-DLRMU(JGL)*DLRMU(JGL),JPKS) |
101 |
|
|
F%RACTHE(JGL) = REAL(1.0_JPRB/SQRT(1.0_JPRB-DLRMU(JGL)*DLRMU(JGL))/& |
102 |
|
✗ |
&REAL(RA,JPKD),JPKS) |
103 |
|
|
ENDDO |
104 |
|
|
|
105 |
|
|
!* 3.3 Working arrays |
106 |
|
✗ |
DO JN=3,R%NTMAX+1 |
107 |
|
✗ |
DO JM=2,JN-1 |
108 |
|
✗ |
DLC(JM,JN) = DC(JN,JM) |
109 |
|
✗ |
DLD(JM,JN) = DD(JN,JM) |
110 |
|
✗ |
DLE(JM,JN) = DE(JN,JM) |
111 |
|
|
ENDDO |
112 |
|
|
ENDDO |
113 |
|
|
|
114 |
|
✗ |
DO JN=1,R%NTMAX+1 |
115 |
|
✗ |
DLA(JN) = SQRT(REAL(2*JN+1,JPKD)) |
116 |
|
✗ |
DLB(JN) = SQRT(REAL(2*JN+1,JPKD)/REAL(JN*(JN+1),JPKD)) |
117 |
|
✗ |
DLF(JN) = REAL(2*JN-1,JPKD)/REAL(JN,JPKD) |
118 |
|
✗ |
DLG(JN) = REAL(JN-1,JPKD)/REAL(JN,JPKD) |
119 |
|
✗ |
DLH(JN) = SQRT(REAL(2*JN+1,JPKD)/REAL(2*JN,JPKD)) |
120 |
|
✗ |
DLI(JN) = REAL(JN,JPKD) |
121 |
|
|
ENDDO |
122 |
|
|
|
123 |
|
|
!CALL GSTATS(1801,0) ! MPL 4.12.08 |
124 |
|
✗ |
DO JGL=D%NLATLS(MYSETW),D%NLATLE(MYSETW) |
125 |
|
✗ |
DLPOL(:,:) = 0.0_JPRB |
126 |
|
✗ |
CALL SUPOL(R%NTMAX+1,DLRMU(JGL),DLPOL,DLA,DLB,DLC,DLD,DLE,DLF,DLG,DLH,DLI) |
127 |
|
|
INM = 0 |
128 |
|
✗ |
IGLLOC = JGL - D%NLATLS(MYSETW) + 1 |
129 |
|
✗ |
DO JM=0,R%NSMAX |
130 |
|
✗ |
DO JN=R%NTMAX+1,JM,-1 |
131 |
|
✗ |
INM = INM+1 |
132 |
|
✗ |
ZPNMG(INM,IGLLOC) = REAL(DLPOL(JM,JN),JPKS) |
133 |
|
|
ENDDO |
134 |
|
|
ENDDO |
135 |
|
|
ENDDO |
136 |
|
|
!CALL GSTATS(1801,1) ! MPL 4.12.08 |
137 |
|
|
!CALL GSTATS(140,1) ! MPL 4.12.08 |
138 |
|
|
|
139 |
|
|
!CALL GSTATS(190,0) ! MPL 4.12.08 |
140 |
|
✗ |
CALL SUTRLE(ZPNMG) |
141 |
|
|
!CALL GSTATS(190,1) ! MPL 4.12.08 |
142 |
|
|
|
143 |
|
|
ICOUNT = 0 |
144 |
|
✗ |
DO JMLOC=1,D%NUMP |
145 |
|
✗ |
IM = D%MYMS(JMLOC) |
146 |
|
✗ |
DO JN=IM,R%NTMAX+2 |
147 |
|
✗ |
ICOUNT = ICOUNT+1 |
148 |
|
|
ENDDO |
149 |
|
|
ENDDO |
150 |
|
|
|
151 |
|
✗ |
ALLOCATE(F%REPSNM(ICOUNT)) |
152 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%REPSNM ',SIZE(F%REPSNM ),SHAPE(F%REPSNM ) |
153 |
|
|
|
154 |
|
|
ICOUNT = 0 |
155 |
|
✗ |
DO JMLOC=1,D%NUMP |
156 |
|
✗ |
IM = D%MYMS(JMLOC) |
157 |
|
✗ |
DO JN=IM,R%NTMAX+2 |
158 |
|
✗ |
ICOUNT = ICOUNT+1 |
159 |
|
|
F%REPSNM(ICOUNT) = REAL(SQRT(REAL(JN*JN-IM*IM,JPKD)/& |
160 |
|
✗ |
&REAL(4*JN*JN-1,JPKD)),JPKS) |
161 |
|
|
ENDDO |
162 |
|
|
ENDDO |
163 |
|
|
|
164 |
|
✗ |
ALLOCATE(F%RN(-1:R%NTMAX+3)) |
165 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%RN ',SIZE(F%RN ),SHAPE(F%RN ) |
166 |
|
✗ |
ALLOCATE(F%RLAPIN(-1:R%NSMAX+2)) |
167 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%RLAPIN ',SIZE(F%RLAPIN ),SHAPE(F%RLAPIN ) |
168 |
|
✗ |
ALLOCATE(F%NLTN(-1:R%NTMAX+3)) |
169 |
|
✗ |
IF (LLP2) WRITE(NOUT,9) 'F%NLTN ',SIZE(F%NLTN ),SHAPE(F%NLTN ) |
170 |
|
|
|
171 |
|
✗ |
DO JN=-1,R%NTMAX+3 |
172 |
|
✗ |
F%RN(JN) = REAL(JN,JPRB) |
173 |
|
✗ |
F%NLTN(JN) = R%NTMAX+2-JN |
174 |
|
|
ENDDO |
175 |
|
✗ |
F%RLAPIN(:) = 0.0_JPRB |
176 |
|
✗ |
F%RLAPIN(0) = 0._JPRB |
177 |
|
✗ |
F%RLAPIN(-1) = 0.0_JPRB |
178 |
|
✗ |
DO JN=1,R%NSMAX+2 |
179 |
|
✗ |
F%RLAPIN(JN)=REAL(-(REAL(RA,JPKD)*REAL(RA,JPKD))/REAL(JN*(JN+1),JPKD),JPKS) |
180 |
|
|
ENDDO |
181 |
|
|
|
182 |
|
✗ |
DEALLOCATE(ZPNMG) |
183 |
|
|
|
184 |
|
|
! ------------------------------------------------------------------ |
185 |
|
|
9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) |
186 |
|
|
|
187 |
|
✗ |
END SUBROUTINE SULEG |
188 |
|
|
END MODULE SULEG_MOD |
189 |
|
|
|