SURFEX v8.1
General documentation of Surfex
facies.F90
Go to the documentation of this file.
1 ! Jan-2013 P. Marguinaud Use JNGEOM & JNEXPL parameters
2 ! Oct-2012 P. Marguinaud 64b LFI
3 ! Jan-2011 P. Marguinaud Thread-safe FA
4 SUBROUTINE facies_fort &
5 & (fa, cdnomc, ktyptr, pslapo, pclopo, pslopo, &
6 & pcodil, ktronc, knlati, knxlon, knlopa, &
7 & knozpa, psinla, kniver, prefer, pahybr, &
8 & pbhybr, ldgard )
9 USE fa_mod, ONLY : fa_com, jpniil, jngeom, jnexpl
10 USE parkind1, ONLY : jprb
11 USE yomhook , ONLY : lhook, dr_hook
12 USE lfi_precision
13 IMPLICIT NONE
14 !****
15 ! Sous-programme servant a obtenir le contenu d'un Cadre.
16 ! ( FACIES... par analogie avec FADIES, avec "C" pour Cadre... )
17 !**
18 ! Arguments : CDNOMC ==> Nom symbolique du cadre;
19 ! (tous de Sortie, KTYPTR ==> Type de transformation horizontale
20 ! sauf CDNOMC) PSLAPO ==> Sinus de la latitude du pole d'interet;
21 ! PCLOPO ==> Cosinus " " longitude " " " ;
22 ! PSLOPO ==> Sinus " " longitude " " " ;
23 ! PCODIL ==> Coefficient de dilatation;
24 ! KTRONC ==> Troncature;
25 ! KNLATI ==> Nombre de latitudes (de pole a pole);
26 ! KNXLON ==> Nombre maxi de longitudes par parallele;
27 ! (Tableau) KNLOPA ==> Nombre de longitudes par parallele;
28 ! (du pole nord vers l'equateur seulement)
29 ! (Tableau) KNOZPA ==> Nombre d'onde zonal maxi par parallele;
30 ! (du pole nord vers l'equateur seulement)
31 ! (Tableau) PSINLA ==> Sinus des latitudes de l'hemisphere nord
32 ! (du pole nord vers l'equateur seulement)
33 ! KNIVER ==> Nombre de niveaux verticaux;
34 ! PREFER ==> Pression de reference (facteur multipli-
35 ! catif de la premiere fonction de la
36 ! coordonnee hybride)
37 ! (Tableau) PAHYBR ==> Valeurs de la fonction "A" de la coordo-
38 ! nnee hybride AUX LIMITES DE COUCHES;
39 ! (Tableau) PBHYBR ==> Valeurs de la fonction "B" de la coordo-
40 ! nnee hybride AUX LIMITES DE COUCHES;
41 ! LDGARD ==> Vrai si le cadre doit etre conserve meme
42 ! apres la fermeture du dernier fichier
43 ! qui s'y rattache.
44 !
45 !
46 !
47 TYPE(fa_com) :: FA
48 INTEGER (KIND=JPLIKB) KTYPTR, KTRONC, KNLATI, KNXLON, KNIVER
49 !
50 INTEGER (KIND=JPLIKB) KNLOPA (fa%jpxpah), KNOZPA (fa%jpxind)
51 !
52 REAL (KIND=JPDBLR) PSLAPO, PCLOPO, PSLOPO, PCODIL, PREFER
53 REAL (KIND=JPDBLR) PSINLA (fa%jpxgeo), PAHYBR (0:fa%jpxniv)
54 REAL (KIND=JPDBLR) PBHYBR (0:fa%jpxniv)
55 !
56 CHARACTER CDNOMC*(*)
57 !
58 LOGICAL LDGARD
59 !
60 INTEGER (KIND=JPLIKB) IREP, IRANGC, ILNOMC
61 INTEGER (KIND=JPLIKB) INIMES, INUMER, ILCDNO, J
62 INTEGER (KIND=JPLIKB) INPAHE, ISULEI, INPIND
63 !
64 LOGICAL LLVERG, LLMLAM
65 CHARACTER(LEN=FA%JPXNOM) CLACTI
66 CHARACTER(LEN=FA%JPLMES) CLMESS
67 CHARACTER(LEN=FA%JPLSPX) CLNSPR
68 LOGICAL LLFATA
69 
70 !
71 !
72 !**
73 ! 0. - SI PREMIERE UTILISATION, APPEL AU SOUS-PROGRAMME "FARINE".
74 !-----------------------------------------------------------------------
75 !
76 REAL(KIND=JPRB) :: ZHOOK_HANDLE
77 IF (lhook) CALL dr_hook('FACIES_MT',0,zhook_handle)
78 clacti=''
79 IF (fa%FACIES_LLPREA) THEN
80  CALL farine_fort &
81 & (fa, 2_jplikb )
82  fa%FACIES_LLPREA=.false.
83 ENDIF
84 !**
85 ! 1. - CONTROLE DE L'ARGUMENT "CDNOMC".
86 !-----------------------------------------------------------------------
87 !
88 llverg=.false.
89 ilcdno=int(len(cdnomc), jplikb)
90 ilnomc=1
91 !
92 IF (ilcdno.LE.0) THEN
93  irep=-65
94  GOTO 1001
95 ELSEIF (cdnomc.EQ.' ') THEN
96  irep=-68
97  GOTO 1001
98 ENDIF
99 !
100 DO j=ilcdno,1,-1
101 !
102 IF (cdnomc(j:j).NE.' ') THEN
103  ilnomc=j
104  GOTO 102
105 ENDIF
106 !
107 ENDDO
108 !
109 102 CONTINUE
110 !
111 IF (ilnomc.GT.fa%NCPCAD) THEN
112  irep=-65
113  GOTO 1001
114 ENDIF
115 !**
116 ! 2. - RECHERCHE DU CADRE DANS LES TABLES.
117 !-----------------------------------------------------------------------
118 !
119 ! Verrouillage global prealable, si necessaire.
120 !
121 IF (fa%LFAMUL) CALL lfiver_fort &
122 & (fa%LFI, fa%VRGLAS,'ON')
123 llverg=fa%LFAMUL
124 !
125 CALL fanuca_fort &
126 & (fa, cdnomc,irangc,.false.)
127 !
128 IF (irangc.EQ.0) THEN
129  irep=-51
130  GOTO 1001
131 ENDIF
132 !**
133 ! 3. - TRANSFERT DES TABLES DU LOGICIEL DANS LES ARGUMENTS.
134 !-----------------------------------------------------------------------
135 !
136 llmlam=fa%CADRE(irangc)%LIMLAM
137 !
138 ktyptr=fa%CADRE(irangc)%NTYPTR
139 ktronc=fa%CADRE(irangc)%MTRONC
140 kniver=fa%CADRE(irangc)%NNIVER
141 knlati=fa%CADRE(irangc)%NLATIT
142 !
143 IF (.NOT.llmlam) THEN
144  inpahe=(1+knlati)/2
145 ELSE
146  isulei=fa%CADRE(irangc)%NOZPAR(1)
147  inpind=2*isulei+4
148 ENDIF
149 !
150 knxlon=fa%CADRE(irangc)%NXLOPA
151 pslapo=fa%CADRE(irangc)%SSLAPO
152 pclopo=fa%CADRE(irangc)%SCLOPO
153 pslopo=fa%CADRE(irangc)%SSLOPO
154 pcodil=fa%CADRE(irangc)%SCODIL
155 prefer=fa%CADRE(irangc)%SPREFE
156 ldgard=fa%CADRE(irangc)%NGARDE.EQ.2.OR. &
157 & (fa%CADRE(irangc)%NGARDE.EQ.1.AND.fa%LIGARD)
158 !
159 IF (.NOT.llmlam) THEN
160 !
161  DO j=1,inpahe
162  knlopa(j)=fa%CADRE(irangc)%NLOPAR(j)
163  knozpa(j)=fa%CADRE(irangc)%NOZPAR(j)
164  psinla(j)=fa%CADRE(irangc)%SINLAT(j)
165  ENDDO
166 !
167 ELSE
168 !
169  DO j=1,jnexpl
170  knlopa(j)=fa%CADRE(irangc)%NLOPAR(j)
171  ENDDO
172  DO j=1,inpind
173  knozpa(j)=fa%CADRE(irangc)%NOZPAR(j)
174  ENDDO
175  DO j=1,jngeom
176  psinla(j)=fa%CADRE(irangc)%SINLAT(j)
177  ENDDO
178 !
179 ENDIF
180 !
181 DO j=0,kniver
182 pahybr(j)=fa%CADRE(irangc)%SFOHYB(1,j)
183 pbhybr(j)=fa%CADRE(irangc)%SFOHYB(2,j)
184 ENDDO
185 !
186 irep=0
187 !**
188 ! 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
189 ! VIA LE sous-programme "FAIPAR" .
190 !-----------------------------------------------------------------------
191 !
192 1001 CONTINUE
193 !
194 ! Deverrouillage global eventuel.
195 !
196 IF (llverg) CALL lfiver_fort &
197 & (fa%LFI, fa%VRGLAS,'OFF')
198 !
199 llfata=irep.NE.0.AND.fa%NRFAGA.NE.2
200 !
201 IF (llfata.OR.fa%NIMSGA.EQ.2) THEN
202  inimes=2
203 ELSE
204  IF (lhook) CALL dr_hook('FACIES_MT',1,zhook_handle)
205  RETURN
206 ENDIF
207 !
208 clnspr='FACIES'
209 !
210 IF (irep.EQ.-65.AND.ilcdno.LE.0) THEN
211  ilnomc=8
212  clacti(1:ilnomc)=fa%CHAINC(:ilnomc)
213 ELSE
214  ilnomc=min(int(len(clacti), jplikb),ilnomc)
215  clacti(1:ilnomc)=cdnomc(1:ilnomc)
216 ENDIF
217 !
218 ilnomc=min(ilnomc,fa%NCPCAD)
219 WRITE (unit=clmess, &
220 & fmt='(''ARGUMENTS SIMPLES= '''''',A,'''''','', &
221 & I2,4('','',F7.4),3('','',I6),'','',I5,'','',F11.4,'', '',L1)') &
222 & clacti(1:ilnomc),ktyptr,pslapo,pclopo,pslopo,pcodil, &
223 & ktronc,knlati,knxlon,kniver,prefer,ldgard
224 inumer=jpniil
225 CALL faipar_fort &
226 & (fa, inumer,inimes,irep,llfata,clmess, &
227 & clnspr,clacti(1:ilnomc),.false.)
228 !
229 IF (lhook) CALL dr_hook('FACIES_MT',1,zhook_handle)
230 END SUBROUTINE facies_fort
231 
232 
233 
234 ! Oct-2012 P. Marguinaud 64b LFI
235 SUBROUTINE facies64 &
236 & (cdnomc, ktyptr, pslapo, pclopo, pslopo, pcodil, &
237 & ktronc, knlati, knxlon, knlopa, knozpa, psinla, &
238 & kniver, prefer, pahybr, pbhybr, ldgard)
239 USE fa_mod, ONLY : fa => fa_com_default, &
240 & fa_com_default_init, &
241 & new_fa_default
242 USE lfi_precision
243 IMPLICIT NONE
244 ! Arguments
245 CHARACTER (LEN=*) CDNOMC ! IN
246 INTEGER (KIND=JPLIKB) KTYPTR ! OUT
247 REAL (KIND=JPDBLR) PSLAPO ! OUT
248 REAL (KIND=JPDBLR) PCLOPO ! OUT
249 REAL (KIND=JPDBLR) PSLOPO ! OUT
250 REAL (KIND=JPDBLR) PCODIL ! OUT
251 INTEGER (KIND=JPLIKB) KTRONC ! OUT
252 INTEGER (KIND=JPLIKB) KNLATI ! OUT
253 INTEGER (KIND=JPLIKB) KNXLON ! OUT
254 INTEGER (KIND=JPLIKB) KNLOPA (*) ! OUT
255 INTEGER (KIND=JPLIKB) KNOZPA (*) ! OUT
256 REAL (KIND=JPDBLR) PSINLA (*) ! OUT
257 INTEGER (KIND=JPLIKB) KNIVER ! OUT
258 REAL (KIND=JPDBLR) PREFER ! OUT
259 REAL (KIND=JPDBLR) PAHYBR (*) ! OUT
260 REAL (KIND=JPDBLR) PBHYBR (*) ! OUT
261 LOGICAL LDGARD ! OUT
262 
263 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
264 
265 CALL facies_fort &
266 & (fa, cdnomc, ktyptr, pslapo, pclopo, pslopo, pcodil, &
267 & ktronc, knlati, knxlon, knlopa, knozpa, psinla, &
268 & kniver, prefer, pahybr, pbhybr, ldgard)
269 
270 END SUBROUTINE facies64
271 
272 SUBROUTINE facies &
273 & (cdnomc, ktyptr, pslapo, pclopo, pslopo, pcodil, &
274 & ktronc, knlati, knxlon, knlopa, knozpa, psinla, &
275 & kniver, prefer, pahybr, pbhybr, ldgard)
276 USE fa_mod, ONLY : fa => fa_com_default, &
277 & fa_com_default_init, &
278 & new_fa_default
279 USE lfi_precision
280 IMPLICIT NONE
281 ! Arguments
282 CHARACTER (LEN=*) CDNOMC ! IN
283 INTEGER (KIND=JPLIKM) KTYPTR ! OUT
284 REAL (KIND=JPDBLR) PSLAPO ! OUT
285 REAL (KIND=JPDBLR) PCLOPO ! OUT
286 REAL (KIND=JPDBLR) PSLOPO ! OUT
287 REAL (KIND=JPDBLR) PCODIL ! OUT
288 INTEGER (KIND=JPLIKM) KTRONC ! OUT
289 INTEGER (KIND=JPLIKM) KNLATI ! OUT
290 INTEGER (KIND=JPLIKM) KNXLON ! OUT
291 INTEGER (KIND=JPLIKM) KNLOPA (*) ! OUT
292 INTEGER (KIND=JPLIKM) KNOZPA (*) ! OUT
293 REAL (KIND=JPDBLR) PSINLA (*) ! OUT
294 INTEGER (KIND=JPLIKM) KNIVER ! OUT
295 REAL (KIND=JPDBLR) PREFER ! OUT
296 REAL (KIND=JPDBLR) PAHYBR (*) ! OUT
297 REAL (KIND=JPDBLR) PBHYBR (*) ! OUT
298 LOGICAL LDGARD ! OUT
299 
300 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
301 
302 CALL facies_mt &
303 & (fa, cdnomc, ktyptr, pslapo, pclopo, pslopo, pcodil, &
304 & ktronc, knlati, knxlon, knlopa, knozpa, psinla, &
305 & kniver, prefer, pahybr, pbhybr, ldgard)
306 
307 END SUBROUTINE facies
308 
309 SUBROUTINE facies_mt &
310 & (fa, cdnomc, ktyptr, pslapo, pclopo, pslopo, pcodil, &
311 & ktronc, knlati, knxlon, knlopa, knozpa, psinla, &
312 & kniver, prefer, pahybr, pbhybr, ldgard)
313 USE fa_mod, ONLY : fa_com
314 USE lfi_precision
315 IMPLICIT NONE
316 ! Arguments
317 type(fa_com) fa ! INOUT
318 CHARACTER (LEN=*) CDNOMC ! IN
319 INTEGER (KIND=JPLIKM) KTYPTR ! OUT
320 REAL (KIND=JPDBLR) PSLAPO ! OUT
321 REAL (KIND=JPDBLR) PCLOPO ! OUT
322 REAL (KIND=JPDBLR) PSLOPO ! OUT
323 REAL (KIND=JPDBLR) PCODIL ! OUT
324 INTEGER (KIND=JPLIKM) KTRONC ! OUT
325 INTEGER (KIND=JPLIKM) KNLATI ! OUT
326 INTEGER (KIND=JPLIKM) KNXLON ! OUT
327 INTEGER (KIND=JPLIKM) KNLOPA (fa%jpxpah) ! OUT
328 INTEGER (KIND=JPLIKM) KNOZPA (fa%jpxind) ! OUT
329 REAL (KIND=JPDBLR) PSINLA (fa%jpxgeo) ! OUT
330 INTEGER (KIND=JPLIKM) KNIVER ! OUT
331 REAL (KIND=JPDBLR) PREFER ! OUT
332 REAL (KIND=JPDBLR) PAHYBR (0:fa%jpxniv) ! OUT
333 REAL (KIND=JPDBLR) PBHYBR (0:fa%jpxniv) ! OUT
334 LOGICAL LDGARD ! OUT
335 ! Local integers
336 INTEGER (KIND=JPLIKB) ITYPTR ! OUT
337 INTEGER (KIND=JPLIKB) ITRONC ! OUT
338 INTEGER (KIND=JPLIKB) INLATI ! OUT
339 INTEGER (KIND=JPLIKB) INXLON ! OUT
340 INTEGER (KIND=JPLIKB) INLOPA (fa%jpxpah) ! OUT
341 INTEGER (KIND=JPLIKB) INOZPA (fa%jpxind) ! OUT
342 INTEGER (KIND=JPLIKB) INIVER ! OUT
343 ! Ancillary variables
344 INTEGER (KIND=JPLIKB) ISZNLOPA, ISZNOZPA
345 INTEGER (KIND=JPLIKB) IRANGC
346 INTEGER (KIND=JPLIKB) ISULEI
347 LOGICAL LLMLAM
348 ! Convert arguments
349 
350 
351 CALL facies_fort &
352 & (fa, cdnomc, ityptr, pslapo, pclopo, pslopo, pcodil, &
353 & itronc, inlati, inxlon, inlopa, inozpa, psinla, &
354 & iniver, prefer, pahybr, pbhybr, ldgard)
355 
356 CALL fanuca_fort &
357 & (fa,cdnomc,irangc,.false.)
358 
359 IF (irangc.NE.0) THEN
360 
361  llmlam=fa%CADRE(irangc)%LIMLAM
362 
363  IF (.NOT.llmlam) THEN
364  isznlopa=(1+inlati)/2
365  isznozpa=(1+inlati)/2
366  ELSE
367  isulei=fa%CADRE(irangc)%NOZPAR(1)
368  isznlopa=8
369  isznozpa=2*isulei+4
370  ENDIF
371 
372  knlopa(1:isznlopa) = int(inlopa(1:isznlopa), jplikm)
373  knozpa(1:isznozpa) = int(inozpa(1:isznozpa), jplikm)
374 
375 ENDIF
376 
377 ktyptr = int( ityptr, jplikm)
378 ktronc = int( itronc, jplikm)
379 knlati = int( inlati, jplikm)
380 knxlon = int( inxlon, jplikm)
381 kniver = int( iniver, jplikm)
382 
383 END SUBROUTINE facies_mt
384 
385 !INTF CDNOMC IN
386 !INTF KTYPTR OUT
387 !INTF PSLAPO OUT
388 !INTF PCLOPO OUT
389 !INTF PSLOPO OUT
390 !INTF PCODIL OUT
391 !INTF KTRONC OUT
392 !INTF KNLATI OUT
393 !INTF KNXLON OUT
394 !INTF KNLOPA OUT DIMS=FA%JPXPAH
395 !INTF KNOZPA OUT DIMS=FA%JPXIND
396 !INTF PSINLA OUT DIMS=FA%JPXGEO
397 !INTF KNIVER OUT
398 !INTF PREFER OUT
399 !INTF PAHYBR OUT DIMS=0:FA%JPXNIV
400 !INTF PBHYBR OUT DIMS=0:FA%JPXNIV
401 !INTF LDGARD OUT
facies64
subroutine facies64(CDNOMC, KTYPTR, PSLAPO, PCLOPO, PSLOPO, PCODIL, KTRONC, KNLATI, KNXLON, KNLOPA, KNOZPA, PSINLA, KNIVER, PREFER, PAHYBR, PBHYBR, LDGARD)
Definition: facies.F90:239
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
facies_fort
subroutine facies_fort(FA, CDNOMC, KTYPTR, PSLAPO, PCLOPO, PSLOPO, PCODIL, KTRONC, KNLATI, KNXLON, KNLOPA, KNOZPA, PSINLA, KNIVER, PREFER, PAHYBR, PBHYBR, LDGARD)
Definition: facies.F90:9
fa_mod::jnexpl
integer(kind=jplikb), parameter jnexpl
Definition: fa_mod.F90:29
fanuca_fort
subroutine fanuca_fort(FA, CDNOMC, KRANGC, LDVERR)
Definition: fanuca.F90:5
fa_mod
Definition: fa_mod.F90:1
lfiver_fort
subroutine lfiver_fort(LFI, PVEROU, CDSENS)
Definition: lfiver.F90:6
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
facies_mt
subroutine facies_mt(FA, CDNOMC, KTYPTR, PSLAPO, PCLOPO, PSLOPO, PCODIL, KTRONC, KNLATI, KNXLON, KNLOPA, KNOZPA, PSINLA, KNIVER, PREFER, PAHYBR, PBHYBR, LDGARD)
Definition: facies.F90:313
farine_fort
subroutine farine_fort(FA, KOPTIO)
Definition: farine.F90:5
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
facies
subroutine facies(CDNOMC, KTYPTR, PSLAPO, PCLOPO, PSLOPO, PCODIL, KTRONC, KNLATI, KNXLON, KNLOPA, KNOZPA, PSINLA, KNIVER, PREFER, PAHYBR, PBHYBR, LDGARD)
Definition: facies.F90:276
lfi_precision::jplikm
integer, parameter jplikm
Definition: lfi_precision.F90:25
fa_mod::fa_com_default
type(fa_com), target, save fa_com_default
Definition: fa_mod.F90:476
fa_mod::jngeom
integer(kind=jplikb), parameter jngeom
Definition: fa_mod.F90:28
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
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