SURFEX v8.1
General documentation of Surfex
farcis.F90
Go to the documentation of this file.
1 ! Oct-2012 P. Marguinaud 64b LFI
2 ! Jan-2011 P. Marguinaud Thread-safe FA
3 SUBROUTINE farcis_fort &
4 & (fa, krep, krang, pchamp, kstron, kpuila )
5 USE fa_mod, ONLY : fa_com, jpniil
6 USE parkind1, ONLY : jprb
7 USE yomhook , ONLY : lhook, dr_hook
8 USE lfi_precision
9 IMPLICIT NONE
10 !****
11 ! Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
12 ! elimination de la "puissance de laplacien" d'un champ en coeffi-
13 ! cients spectraux issu d'un codage GRIB, de maniere a restituer
14 ! le champ "d'origine" (a la precision du codage pres) .
15 ! ( Reconstitution des CoeffIcients Spectraux )
16 !**
17 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
18 ! KRANG (Entree) ==> Rang de l'unite logique;
19 ! ( Tableau ) PCHAMP (Entree ET Sortie) ==> Champ en coef. spectraux;
20 ! KSTRON (Entree) ==> Sous-troncature non compactee;
21 ! KPUILA (Entree) ==> Puissance de laplacien utilisee.
22 !
23 ! ( Les 2 derniers parametres sont ceux qui ont ete effectivement
24 ! utilises lors de l'ecriture du champ )
25 !*
26 ! En mode multi-taches, il doit y avoir verrouillage du fichier
27 ! concerne avant l'appel au sous-programme.
28 !
29 !
30 !
31 TYPE(fa_com) :: FA
32 INTEGER (KIND=JPLIKB) KREP, KRANG, KSTRON, KPUILA
33 !
34 REAL (KIND=JPDBLR) PCHAMP (fa%jpxcsp)
35 !
36 INTEGER (KIND=JPLIKB) IRANGC, ITRONC, INUMER, IDIMNC
37 INTEGER (KIND=JPLIKB) ILCHAM, IMTRONC, IPUISX, J
38 INTEGER (KIND=JPLIKB) INDICE, JN, INDLAP, IMLIM
39 INTEGER (KIND=JPLIKB) IOFF, IM, JIND, IPUIS2
40 INTEGER (KIND=JPLIKB) IRAPOR, IPUISR, INIMES, IDEB, IFIN
41 !
42 LOGICAL LLMLAM
43 !
44 CHARACTER(LEN=FA%JPXNOM) CLACTI
45 CHARACTER(LEN=FA%JPLMES) CLMESS
46 CHARACTER(LEN=FA%JPLSPX) CLNSPR
47 LOGICAL LLFATA
48 
49 !**
50 ! 1. - CONTROLES DES PARAMETRES D'APPEL, INITIALISATIONS.
51 !-----------------------------------------------------------------------
52 !
53 REAL(KIND=JPRB) :: ZHOOK_HANDLE
54 IF (lhook) CALL dr_hook('FARCIS_MT',0,zhook_handle)
55 clacti=''
56 IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
57  krep=-66
58  GOTO 1001
59 ENDIF
60 !
61 IF (fa%LIXLAP) THEN
62  CALL faixla_fort &
63 & (fa)
64  fa%LIXLAP=.false.
65 ENDIF
66 !
67 irangc=fa%FICHIER(krang)%NUCADR
68 itronc=fa%CADRE(irangc)%MTRONC
69 llmlam=fa%CADRE(irangc)%LIMLAM
70 !
71 IF (llmlam) imtronc=fa%CADRE(irangc)%NOZPAR(2)
72 IF (itronc.LE.kstron) THEN
73  krep=-88
74  GOTO 1001
75 ELSEIF (llmlam.AND.imtronc.LE.kstron) THEN
76  krep=-88
77  GOTO 1001
78 ELSEIF (llmlam.AND.(imtronc.GT.3*itronc &
79 & .OR.itronc.GT.3*imtronc)) THEN
80 ! Il s'agit d'un garde-fou, modifiable (ne pas oublier FAPULA et FACSIM)
81  krep=-114
82  GOTO 1001
83 ELSE
84  krep=0
85 ENDIF
86 !
87 idimnc=(1+kstron)**2
88 IF (llmlam) THEN
89  ilcham=fa%CADRE(irangc)%NSFLAM
90 ELSE
91  ilcham=(1+itronc)**2
92 ENDIF
93 !**
94 ! 2. - RECONSTITUTION DU CHAMP "D'ORIGINE", DEBARRASSE DE LA
95 ! PUISSANCE DE LAPLACIEN QUI N'AFFECTE QUE LA PARTIE HORS
96 ! SOUS-TRONCATURE NON COMPACTEE.
97 !-----------------------------------------------------------------------
98 !
99 ! On essaie d'eviter l'exponentiation, en preferant multiplier
100 ! que diviser.
101 !
102 IF (kpuila.NE.0) THEN
103 !
104  ipuisx=abs(kpuila)
105 !
106  IF (kpuila.GT.0) THEN
107  indice=1
108  ELSE
109  indice=0
110  ENDIF
111 !
112  IF (ipuisx.LE.fa%JPUILA) THEN
113 !
114  IF (llmlam) THEN
115 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP) &
116 !$OMP& IF(FA%LOPENMP)
117  DO jn=1,itronc
118  imlim=kstron-jn
119  ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
120 & fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
121  ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
122  DO jind=ideb,ifin
123  ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
124  im=ioff/4
125  indlap=((jn-1)*fa%JPXTRO)+im
126  pchamp(jind)=pchamp(jind)*fa%XLAP2DA(indlap,ipuisx,indice)
127  ENDDO
128  ENDDO
129 !$OMP END PARALLEL DO
130  ELSE
131  DO j=idimnc+1,ilcham
132  pchamp(j)=pchamp(j)*fa%XLAP2D(j,ipuisx,indice)
133  ENDDO
134  ENDIF
135  ELSEIF (ipuisx.LE.2*fa%JPUILA) THEN
136  ipuis2=ipuisx/2
137 !
138  IF (ipuisx.EQ.2*ipuis2) THEN
139 !
140  IF (llmlam) THEN
141 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP) &
142 !$OMP& IF(FA%LOPENMP)
143  DO jn=1,itronc
144  imlim=kstron-jn
145  ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
146 & fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
147  ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
148  DO jind=ideb,ifin
149  ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
150  im=ioff/4
151  indlap=((jn-1)*fa%JPXTRO)+im
152  pchamp(jind)=pchamp(jind) &
153 & *( fa%XLAP2DA(indlap,ipuis2,indice)**2 )
154  ENDDO
155  ENDDO
156 !$OMP END PARALLEL DO
157  ELSE
158  DO j=idimnc+1,ilcham
159  pchamp(j)=pchamp(j)*( fa%XLAP2D(j,ipuis2,indice)**2 )
160  ENDDO
161  ENDIF
162 !
163  ELSE
164 !
165  IF (llmlam) THEN
166 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP) &
167 !$OMP& IF(FA%LOPENMP)
168  DO jn=1,itronc
169  imlim=kstron-jn
170  ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
171 & fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
172  ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
173  DO jind=ideb,ifin
174  ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
175  im=ioff/4
176  indlap=((jn-1)*fa%JPXTRO)+im
177  pchamp(jind)=pchamp(jind) &
178 & *( fa%XLAP2DA(indlap,fa%JPUILA,indice) &
179 & *fa%XLAP2DA(indlap,ipuisx-fa%JPUILA,indice) )
180  ENDDO
181  ENDDO
182 !$OMP END PARALLEL DO
183  ELSE
184  DO j=idimnc+1,ilcham
185  pchamp(j)=pchamp(j)*( fa%XLAP2D(j,fa%JPUILA,indice) &
186 & *fa%XLAP2D(j,ipuisx-fa%JPUILA,indice) )
187  ENDDO
188  ENDIF
189 !
190  ENDIF
191 !
192  ELSE
193  irapor=1+(ipuisx-1)/fa%JPUILA
194  ipuisr=ipuisx/irapor
195 !
196  IF (ipuisx.EQ.irapor*ipuisr) THEN
197 !
198  IF (llmlam) THEN
199 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP) &
200 !$OMP& IF(FA%LOPENMP)
201  DO jn=1,itronc
202  imlim=kstron-jn
203  ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
204 & fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
205  ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
206  DO jind=ideb,ifin
207  ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
208  im=ioff/4
209  indlap=((jn-1)*fa%JPXTRO)+im
210  pchamp(jind)=pchamp(jind) &
211 & *( fa%XLAP2DA(indlap,ipuisr,indice)**irapor )
212  ENDDO
213  ENDDO
214 !$OMP END PARALLEL DO
215  ELSE
216  DO j=idimnc+1,ilcham
217  pchamp(j)=pchamp(j)*( fa%XLAP2D(j,ipuisr,indice)**irapor )
218  ENDDO
219  ENDIF
220 !
221  ELSE
222 !
223  IF (llmlam) THEN
224 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP) &
225 !$OMP& IF(FA%LOPENMP)
226  DO jn=1,itronc
227  imlim=kstron-jn
228  ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
229 & fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
230  ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
231  DO jind=ideb,ifin
232  ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
233  im=ioff/4
234  indlap=((jn-1)*fa%JPXTRO)+im
235  pchamp(jind)=pchamp(jind) &
236 & *( fa%XLAP2DA(indlap,fa%JPUILA,indice)**(irapor-1) &
237 & *fa%XLAP2DA(indlap,ipuisx-fa%JPUILA*(irapor-1),indice) )
238  ENDDO
239  ENDDO
240 !$OMP END PARALLEL DO
241  ELSE
242  DO j=idimnc+1,ilcham
243  pchamp(j)=pchamp(j)* &
244 & (fa%XLAP2D(j,fa%JPUILA,indice)**(irapor-1) &
245 & *fa%XLAP2D(j,ipuisx-fa%JPUILA*(irapor-1),indice) )
246  ENDDO
247  ENDIF
248 !
249  ENDIF
250 !
251  ENDIF
252 !
253 ENDIF
254 !**
255 ! 10. - PHASE TERMINALE : MESSAGERIE EVENTUELLE,
256 ! VIA LE SOUS-PROGRAMME "FAIPAR" .
257 !-----------------------------------------------------------------------
258 !
259 1001 CONTINUE
260 llfata=llmoer(krep,krang)
261 !
262 IF (fa%LFAMOP.OR.llfata) THEN
263  inimes=2
264  clnspr='FARCIS'
265  inumer=jpniil
266  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I4, &
267 & '', PCHAMP(1)='',G12.5,'', KSTRON='',I4,'', KPUILA='',I3)') &
268 & krep,krang,pchamp(1),kstron,kpuila
269  CALL faipar_fort &
270 & (fa, inumer,inimes,krep,.false.,clmess, &
271 & clnspr,clacti,.false.)
272 ENDIF
273 !
274 IF (lhook) CALL dr_hook('FARCIS_MT',1,zhook_handle)
275 
276 CONTAINS
277 
278 #include "facom2.llmoer.h"
279 
280 END SUBROUTINE farcis_fort
281 
282 
283 
284 ! Oct-2012 P. Marguinaud 64b LFI
285 SUBROUTINE farcis64 &
286 & (krep, krang, pchamp, kstron, kpuila)
287 USE fa_mod, ONLY : fa => fa_com_default, &
288 & fa_com_default_init, &
289 & new_fa_default
290 USE lfi_precision
291 IMPLICIT NONE
292 ! Arguments
293 INTEGER (KIND=JPLIKB) KREP ! OUT
294 INTEGER (KIND=JPLIKB) KRANG ! IN
295 REAL (KIND=JPDBLR) PCHAMP (*) ! INOUT
296 INTEGER (KIND=JPLIKB) KSTRON ! IN
297 INTEGER (KIND=JPLIKB) KPUILA ! IN
298 
299 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
300 
301 CALL farcis_fort &
302 & (fa, krep, krang, pchamp, kstron, kpuila)
303 
304 END SUBROUTINE farcis64
305 
306 SUBROUTINE farcis &
307 & (krep, krang, pchamp, kstron, kpuila)
308 USE fa_mod, ONLY : fa => fa_com_default, &
309 & fa_com_default_init, &
310 & new_fa_default
311 USE lfi_precision
312 IMPLICIT NONE
313 ! Arguments
314 INTEGER (KIND=JPLIKM) KREP ! OUT
315 INTEGER (KIND=JPLIKM) KRANG ! IN
316 REAL (KIND=JPDBLR) PCHAMP (*) ! INOUT
317 INTEGER (KIND=JPLIKM) KSTRON ! IN
318 INTEGER (KIND=JPLIKM) KPUILA ! IN
319 
320 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
321 
322 CALL farcis_mt &
323 & (fa, krep, krang, pchamp, kstron, kpuila)
324 
325 END SUBROUTINE farcis
326 
327 SUBROUTINE farcis_mt &
328 & (fa, krep, krang, pchamp, kstron, kpuila)
329 USE fa_mod, ONLY : fa_com
330 USE lfi_precision
331 IMPLICIT NONE
332 ! Arguments
333 type(fa_com) fa ! INOUT
334 INTEGER (KIND=JPLIKM) KREP ! OUT
335 INTEGER (KIND=JPLIKM) KRANG ! IN
336 REAL (KIND=JPDBLR) PCHAMP (fa%jpxcsp) ! INOUT
337 INTEGER (KIND=JPLIKM) KSTRON ! IN
338 INTEGER (KIND=JPLIKM) KPUILA ! IN
339 ! Local integers
340 INTEGER (KIND=JPLIKB) IREP ! OUT
341 INTEGER (KIND=JPLIKB) IRANG ! IN
342 INTEGER (KIND=JPLIKB) ISTRON ! IN
343 INTEGER (KIND=JPLIKB) IPUILA ! IN
344 ! Convert arguments
345 
346 irang = int( krang, jplikb)
347 istron = int( kstron, jplikb)
348 ipuila = int( kpuila, jplikb)
349 
350 CALL farcis_fort &
351 & (fa, irep, irang, pchamp, istron, ipuila)
352 
353 krep = int( irep, jplikm)
354 
355 END SUBROUTINE farcis_mt
356 
357 !INTF KREP OUT
358 !INTF KRANG IN
359 !INTF PCHAMP INOUT DIMS=FA%JPXCSP
360 !INTF KSTRON IN
361 !INTF KPUILA IN
lfi_precision::jplikb
integer, parameter jplikb
Definition: lfi_precision.F90:25
yomhook::dr_hook
Definition: yomhook.F90:20
fa_mod::fa_com_default_init
logical, save fa_com_default_init
Definition: fa_mod.F90:477
fa_mod::new_fa_default
subroutine new_fa_default()
Definition: fa_mod.F90:649
fa_mod
Definition: fa_mod.F90:1
farcis64
subroutine farcis64(KREP, KRANG, PCHAMP, KSTRON, KPUILA)
Definition: farcis.F90:287
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
farcis
subroutine farcis(KREP, KRANG, PCHAMP, KSTRON, KPUILA)
Definition: farcis.F90:308
farcis_fort
subroutine farcis_fort(FA, KREP, KRANG, PCHAMP, KSTRON, KPUILA)
Definition: farcis.F90:5
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
lfi_precision::jplikm
integer, parameter jplikm
Definition: lfi_precision.F90:25
faixla_fort
subroutine faixla_fort(FA)
Definition: faixla.F90:5
fa_mod::fa_com_default
type(fa_com), target, save fa_com_default
Definition: fa_mod.F90:476
faipar_fort
subroutine faipar_fort(FA, KNUMER, KNIMES, KCODE, LDFATA, CDMESS, CDNSPR, CDACTI, LDRLFI)
Definition: faipar.F90:6
fa_mod::fa_com
Definition: fa_mod.F90:252
farcis_mt
subroutine farcis_mt(FA, KREP, KRANG, PCHAMP, KSTRON, KPUILA)
Definition: farcis.F90:329
lfi_precision
Definition: lfi_precision.F90:1
fa_mod::jpniil
integer(kind=jplikb), parameter jpniil
Definition: fa_mod.F90:31
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13