SURFEX v8.1
General documentation of Surfex
lfiecx.F90
Go to the documentation of this file.
1 ! Oct-2012 P. Marguinaud 64b LFI
2 ! Jan-2011 P. Marguinaud Thread-safe LFI
3 SUBROUTINE lfiecx_fort &
4 & (lfi, krep, krang, krec, kzone, &
5 & ldadon, kretin )
6 USE lfimod, ONLY : lficom
7 USE parkind1, ONLY : jprb
8 USE yomhook , ONLY : lhook, dr_hook
9 USE lfi_precision
10 IMPLICIT NONE
11 !****
12 ! SOUS-PROGRAMME *INTERNE* DU LOGICIEL DE FICHIERS INDEXES LFI
13 ! ECRITURE SUR FICHIER D'UNE PAGE DE DONNEES OU D'INDEX LONG./POS.,
14 ! EN "BOUCHANT LES TROUS" SI ON N'ECRIT PAS A LA SUITE DU DERNIER
15 ! ARTICLE PRESENT SUR LE FICHIER, ET EN ESSAYANT D'ECRIRE DES ARTI-
16 ! CLES ADJACENTS SI ON N'ECRIT PAS UN ARTICLE (PHYSIQUE) "NOUVEAU".
17 ! CE S/P MET A JOUR LE NOMBRE D'ARTICLES PHYSIQUES DU FICHIER,
18 ! ET DANS LE CAS D'UN ARTICLE PHYSIQUE DE DONNEES, LE LFI%NUMERO MAXI.
19 ! D'ARTICLE PHYSIQUE DE DONNEES DU FICHIER.
20 !**
21 ! ARGUMENTS : KREP (SORTIE) ==> CODE-REPONSE DE L'ECRITURE FORTRAN;
22 ! KRANG (ENTREE) ==> RANG EN MEMOIRE DE L'UNITE LOGIQUE;
23 ! KREC (ENTREE) ==> LFI%NUMERO D'ENREGISTREMENT A ECRIRE;
24 ! KZONE (ENTREE) ==> PREMIER MOT A ECRIRE;
25 ! LDADON (ENTREE) ==> VRAI SI ARTICLE DE DONNEES;
26 ! KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
27 !
28 !
29 TYPE(lficom) :: LFI
30 INTEGER (KIND=JPLIKB) KZONE (lfi%jplarx)
31 INTEGER (KIND=JPLIKB) KREP, KRANG, KREC, KRETIN
32 INTEGER (KIND=JPLIKB) INADJA (2), IPOSAD (lfi%jpnpdf)
33 INTEGER (KIND=JPLIKB) IMDESC, INUMER, INPPIM, JREC
34 INTEGER (KIND=JPLIKB) IPODPI, IFACTM, ILARPH, INALPP
35 INTEGER (KIND=JPLIKB) INBPIR, INDIK1, INDIK2, J
36 INTEGER (KIND=JPLIKB) INDIC1, INDIC2, INUMPD, INAPHY
37 INTEGER (KIND=JPLIKB) IJ, IRGPIM, IRGPIF, IDEBSE
38 INTEGER (KIND=JPLIKB) INDIS1, INDIS2, JSENS, ISENS
39 INTEGER (KIND=JPLIKB) IREC, INUMAP, IRECX, INIMES
40 INTEGER (KIND=JPLIKB) IRETOU, IRETIN
41 !
42 LOGICAL LDADON, LLSAUT, LLFILT, LLLOIN
43 !
44 CHARACTER(LEN=LFI%JPLSPX) CLNSPR
45 CHARACTER(LEN=LFI%JPLMES) CLMESS
46 CHARACTER(LEN=LFI%JPLFTX) CLACTI
47 LOGICAL LLFATA
48 
49 !**
50 ! 1. - CONTROLES ET INITIALISATIONS.
51 !-----------------------------------------------------------------------
52 !
53 REAL(KIND=JPRB) :: ZHOOK_HANDLE
54 IF (lhook) CALL dr_hook('LFIECX_FORT',0,zhook_handle)
55 clacti=''
56 IF (krang.LE.0.OR.krang.GT.lfi%JPNXFI) THEN
57  inumer=lfi%JPNIL
58 ELSE
59  inumer=lfi%NUMERO(krang)
60 ENDIF
61 !
62 iretou=0
63 !
64 IF (inumer.EQ.lfi%JPNIL) THEN
65  krep=-14
66  GOTO 1001
67 ENDIF
68 !
69 inaphy=0
70 llsaut=.false.
71 inppim=lfi%NPPIMM(krang)
72 ipodpi=lfi%NPODPI(krang)
73 ifactm=lfi%MFACTM(krang)
74 ilarph=lfi%JPLARD*ifactm
75 inalpp=lfi%JPNAPP*ifactm
76 inbpir=lfi%MDES1D(ixm(lfi%JPNPIR,krang))
77 llloin=krec.GT.lfi%MDES1D(ixm(lfi%JPNAPH,krang))
78 !
79 IF (llloin) THEN
80 !**
81 ! 2. - CAS OU L'ON ECRIT PLUS LOIN QUE LE DERNIER ARTICLE
82 ! EFFECTIVEMENT ECRIT SUR LE FICHIER.
83 !-----------------------------------------------------------------------
84 !
85  indik1=1
86  indik2=lfi%JPNPDF
87 !*
88 ! 2.1 - ECRITURE D'EVENTUELS ARTICLES ENTRE LE DERNIER PRESENT
89 ! SUR LE FICHIER, ET CELUI QUE L'ON DOIT ECRIRE.
90 !-----------------------------------------------------------------------
91 !
92  DO jrec=lfi%MDES1D(ixm(lfi%JPNAPH,krang))+1,krec-1
93 !
94  IF (llsaut) THEN
95  llsaut=.false.
96  GOTO 213
97  ENDIF
98 !
99  indic1=indik1
100  indic2=indik2
101 !
102  DO j=indic1,indic2
103  inumpd=mod(lfi%NDERPD(krang)+j,lfi%JPNPDF)
104 !
105  IF (lfi%NUMAPD(inumpd,krang).EQ.jrec) THEN
106  IF (j.EQ.indik1) indik1=indik1+1
107  IF (j.EQ.indik2) indik2=indik2-1
108  IF (lfi%LMISOP) WRITE (unit=lfi%NULOUT,fmt=*) &
109 & '$$$ LFIECX - INUMPD= ',inumpd, &
110 & ', INDIK1= ', indik1,', INDIK2= ',indik2,' $$$'
111 !
112 ! ARTICLE PHYSIQUE TROUVE DANS LES PAGES DE DONNEES;
113 ! IL S'AGIT DONC D'UNE PAGE DE DONNEES NON ENCORE ECRITE,
114 ! ET FORCEMENT COMPLETE DANS CE CAS.
115 !
116  IF (.NOT.lfi%LECRPD(inumpd,krang) &
117 & .OR.lfi%NLONPD(inumpd,krang).NE.ilarph) THEN
118  krep=-16
119  GOTO 1001
120  ENDIF
121 !
122  inaphy=jrec
123  CALL lfiedo_fort &
124 & (lfi, krep,inumer,jrec, &
125 & lfi%MTAMPD(ixt(1_jplikb ,inumpd,krang)), &
126 & lfi%NBWRIT(krang),ifactm, &
127 & lfi%YLFIC (krang), iretin)
128 
129 !
130  IF (iretin.EQ.1) THEN
131  GOTO 903
132  ELSEIF (iretin.NE.0) THEN
133  GOTO 1001
134  ENDIF
135 !
136  lfi%LECRPD(inumpd,krang)=.false.
137  GOTO 213
138  ELSEIF (lfi%NUMAPD(inumpd,krang).LT.jrec) THEN
139  IF (j.EQ.indik1) indik1=indik1+1
140  IF (j.EQ.indik2) indik2=indik2-1
141  ENDIF
142 !
143  ENDDO
144 !
145 ! CAS OU L'ARTICLE N'A PAS ETE TROUVE DANS LES PAGES DE DONNEES;
146 ! IL S'AGIT DONC D'UN ARTICLE D'INDEX "EXCEDENTAIRE", NON ENCORE
147 ! ECRIT, ET EN FAIT IL Y A DEUX ARTICLES CONSECUTIFS A ECRIRE.
148 !
149  DO j=1,inppim
150 !
151 ! ON COMMENCE EN FAIT LA RECHERCHE PAR LA DERNIERE P.P.I., CAR IL
152 ! Y A PRATIQUEMENT TOUTES LES CHANCES QUE CE SOIT CELLE CHERCHEE.
153 ! ( LA PREMIERE EST, PAR CONSTRUCTION, NON EXCEDENTAIRE )
154 !
155  IF (j.EQ.1) THEN
156  ij=ipodpi
157  ELSEIF (j.EQ.ipodpi) THEN
158  cycle
159  ELSE
160  ij=j
161  ENDIF
162 !
163  irgpim=lfi%MRGPIM(ij,krang)
164  irgpif=lfi%MRGPIF(irgpim)
165  IF (irgpif.LE.inbpir) cycle
166  CALL lfirec_fort &
167 & (lfi, irgpif,krang,irec)
168 !
169  IF (irec.EQ.jrec) THEN
170 !
171  IF (.NOT.lfi%LECRPI(irgpim,1).OR. &
172 & .NOT.lfi%LECRPI(irgpim,2)) THEN
173  krep=-16
174  GOTO 1001
175  ENDIF
176 !
177  inaphy=jrec
178  CALL lfiecc_fort &
179 & (lfi, krep,inumer,jrec, &
180 & lfi%CNOMAR(ixc(1_jplikb ,irgpim)), &
181 & lfi%NBWRIT(krang),ifactm, &
182 & lfi%YLFIC (krang),iretin)
183 !
184  IF (iretin.EQ.1) THEN
185  GOTO 903
186  ELSEIF (iretin.NE.0) THEN
187  GOTO 1001
188  ENDIF
189 !
190  inaphy=jrec+1
191  CALL lfiedo_fort &
192 & (lfi, krep,inumer,jrec+1, &
193 & lfi%MLGPOS(ixm(1_jplikb ,irgpim)), &
194 & lfi%NBWRIT(krang),ifactm, &
195 & lfi%YLFIC (krang),iretin)
196 !
197  IF (iretin.EQ.1) THEN
198  GOTO 903
199  ELSEIF (iretin.NE.0) THEN
200  GOTO 1001
201  ENDIF
202 !
203  lfi%LECRPI(irgpim,1)=ij.NE.ipodpi.OR. &
204 & lfi%NALDPI(krang).EQ.inalpp
205  lfi%LECRPI(irgpim,2)=lfi%LECRPI(irgpim,1)
206  llsaut=.true.
207  GOTO 213
208  ENDIF
209 !
210  ENDDO
211 !
212  WRITE (unit=lfi%NULOUT,fmt=*) &
213 & '$$$ LFIECX - APRES ETIQUETTE 212, JREC= ', &
214 & jrec,' NON TROUVE $$$'
215  krep=-16
216  GOTO 1001
217 !
218 213 CONTINUE
219 !
220  ENDDO
221 !
222  idebse=2
223 !
224 ELSE
225 !
226 ! CAS OU L'ARTICLE PHYSIQUE A ECRIRE EXISTE DEJA SUR LE FICHIER.
227 !
228  idebse=1
229 !
230 ENDIF
231 !**
232 ! 3. - CAS "GENERAL" .
233 !-----------------------------------------------------------------------
234 !*
235 ! 3.1 - RECHERCHE D'ARTICLES PHYSIQUES ADJACENTS A ECRIRE,
236 ! PARMI LES PAGES DE DONNEES *COMPLETES* EXCLUSIVEMENT.
237 !-----------------------------------------------------------------------
238 !
239 indis1=0
240 indis2=lfi%JPNPDF-1
241 !
242 DO jsens=idebse,2
243 isens=2*jsens-3
244 inadja(jsens)=(lfi%JPNPDF+1)*(jsens-1)
245 IF (.NOT.ldadon.AND.jsens.EQ.2) GOTO 320
246 indik1=indis1
247 indik2=indis2
248 irec=krec
249 !
250 311 CONTINUE
251 irec=irec+isens
252 indic1=indik1
253 indic2=indik2
254 !
255 DO j=indic1,indic2
256 inumap=lfi%NUMAPD(j,krang)
257 llfilt=lfi%LECRPD(j,krang).AND.lfi%NLONPD(j,krang).EQ.ilarph
258 !
259 IF (llfilt.AND.inumap.EQ.irec) THEN
260  inadja(jsens)=inadja(jsens)-isens
261  iposad(inadja(jsens))=j
262  IF (j.EQ.indik1) indik1=indik1+1
263  IF (j.EQ.indik2) indik2=indik2-1
264  IF (j.EQ.indis1) indis1=indis1+1
265  IF (j.EQ.indis2) indis2=indis2-1
266  GOTO 311
267 ELSEIF(.NOT.llfilt.OR.inumap.EQ.krec &
268 & .OR.abs(inumap-krec).GT.lfi%JPNPDF) THEN
269  IF (j.EQ.indis1) indis1=indis1+1
270  IF (j.EQ.indis2) indis2=indis2-1
271 ELSEIF(inumap*isens.LT.irec*isens) THEN
272  IF (j.EQ.indik1) indik1=indik1+1
273  IF (j.EQ.indik2) indik2=indik2-1
274 ENDIF
275 !
276 ENDDO
277 !
278 ENDDO
279 !*
280 ! 3.2 - ECRITURE DES (EVENTUELS) ARTICLES ADJACENTS DE LFI%NUMERO
281 ! *INFERIEUR* A CELUI QUE LE SOUS-PROGRAMME DOIT ECRIRE.
282 !-----------------------------------------------------------------------
283 !
284 320 CONTINUE
285 !
286 IF (.NOT.llloin) THEN
287  irec=krec-inadja(1)
288 !
289  DO j=inadja(1),1,-1
290  ij=iposad(j)
291  inaphy=irec
292  CALL lfiedo_fort &
293 & (lfi, krep,inumer,irec, &
294 & lfi%MTAMPD(ixt(1_jplikb ,ij,krang)), &
295 & lfi%NBWRIT(krang),ifactm, &
296 & lfi%YLFIC (krang), iretin)
297 !
298  IF (iretin.EQ.1) THEN
299  GOTO 903
300  ELSEIF (iretin.NE.0) THEN
301  GOTO 1001
302  ENDIF
303 !
304  lfi%LECRPD(ij,krang)=.false.
305  irec=irec+1
306  ENDDO
307 !
308 ENDIF
309 !*
310 ! 3.3 - ECRITURE DE L'ARTICLE DEMANDE.
311 !-----------------------------------------------------------------------
312 !
313 inaphy=krec
314 CALL lfiedo_fort &
315 & (lfi, krep,inumer,krec,kzone, &
316 & lfi%NBWRIT(krang),ifactm, &
317 & lfi%YLFIC (krang),iretin)
318 !
319 IF (iretin.EQ.1) THEN
320  GOTO 903
321 ELSEIF (iretin.NE.0) THEN
322  GOTO 1001
323 ENDIF
324 !
325 !*
326 ! 3.4 - ECRITURE DES (EVENTUELS) ARTICLES ADJACENTS DE LFI%NUMERO
327 ! *SUPERIEUR* A CELUI QUE LE SOUS-PROGRAMME DOIT ECRIRE.
328 !-----------------------------------------------------------------------
329 !
330 irec=krec
331 !
332 DO j=lfi%JPNPDF,inadja(2),-1
333 irec=irec+1
334 ij=iposad(j)
335 inaphy=irec
336 CALL lfiedo_fort &
337 & (lfi, krep,inumer,irec, &
338 & lfi%MTAMPD(ixt(1_jplikb ,ij,krang)), &
339 & lfi%NBWRIT(krang),ifactm, &
340 & lfi%YLFIC (krang), &
341 & iretin)
342 !
343 IF (iretin.EQ.1) THEN
344  GOTO 903
345 ELSEIF (iretin.NE.0) THEN
346  GOTO 1001
347 ENDIF
348 !
349 lfi%LECRPD(ij,krang)=.false.
350 ENDDO
351 !
352 irecx=krec+lfi%JPNPDF-inadja(2)+1
353 !**
354 ! 4. - DANS LE CAS D'UN ARTICLE DE DONNEES, MISE A JOUR DU LFI%NUMERO
355 ! MAXI D'ENREGISTREMENT DE CES ARTICLES PHYSIQUES, ET DANS
356 ! TOUS LES CAS MISE A JOUR DU NOMBRE D'ARTICLES PHYSIQUES.
357 !-----------------------------------------------------------------------
358 !
359 IF (ldadon) THEN
360  imdesc=lfi%MDES1D(ixm(lfi%JPAXPD,krang))
361  lfi%MDES1D(ixm(lfi%JPAXPD,krang))=max(imdesc,irecx)
362 ENDIF
363 !
364 imdesc=lfi%MDES1D(ixm(lfi%JPNAPH,krang))
365 lfi%MDES1D(ixm(lfi%JPNAPH,krang))=max(imdesc,irecx)
366 krep=0
367 GOTO 1001
368 !**
369 ! 9. - CI-DESSOUS, ETIQUETTE DE BRANCHEMENT EN CAS D'ERREUR ECR.
370 ! ON FORCE LE CODE DE RETOUR A ETRE POSITIF.
371 !-----------------------------------------------------------------------
372 !
373 903 CONTINUE
374 iretou=1
375 clacti='WRITE'
376 krep=abs(krep)
377 lfi%NUMAPH(krang)=inaphy
378 !**
379 ! 10. - PHASE TERMINALE : MESSAGERIE INTERNE EVENTUELLE,
380 ! VIA LE SOUS-PROGRAMME "LFIEMS", PUIS RETOUR.
381 !-----------------------------------------------------------------------
382 !
383 1001 CONTINUE
384 llfata=llmoer(krep,krang)
385 !
386 IF (krep.EQ.0) THEN
387  kretin=0
388 ELSEIF (krep.GT.0) THEN
389  kretin=iretou
390 ELSE
391  kretin=3
392 ENDIF
393 !
394 IF (lfi%LMISOP.OR.llfata) THEN
395  inimes=2
396  clnspr='LFIECX'
397  WRITE (unit=clmess,fmt='(''KREP='',I5,'', KRANG='',I3, &
398 & '', KREC='',I6,'', LDADON='',L2,'', KRETIN='',I2)') &
399 & krep,krang,krec,ldadon,kretin
400  CALL lfiems_fort &
401 & (lfi, inumer,inimes,krep,.false.,clmess, &
402 & clnspr,clacti)
403 ENDIF
404 !
405 IF (lhook) CALL dr_hook('LFIECX_FORT',1,zhook_handle)
406 
407 CONTAINS
408 
409 #include "lficom2.ixc.h"
410 #include "lficom2.ixm.h"
411 #include "lficom2.ixt.h"
412 #include "lficom2.llmoer.h"
413 
414 END SUBROUTINE lfiecx_fort
415 
416 
417 
418 ! Oct-2012 P. Marguinaud 64b LFI
419 SUBROUTINE lfiecx64 &
420 & (krep, krang, krec, kzone, ldadon, kretin)
421 USE lfimod, ONLY : lfi => lficom_default, &
422 & lficom_default_init, &
423 & new_lfi_default
424 USE lfi_precision
425 IMPLICIT NONE
426 ! Arguments
427 INTEGER (KIND=JPLIKB) KREP ! OUT
428 INTEGER (KIND=JPLIKB) KRANG ! IN
429 INTEGER (KIND=JPLIKB) KREC ! IN
430 INTEGER (KIND=JPLIKB) KZONE (*) ! IN
431 LOGICAL LDADON ! IN
432 INTEGER (KIND=JPLIKB) KRETIN ! OUT
433 
434 IF (.NOT. lficom_default_init) CALL new_lfi_default ()
435 
436 CALL lfiecx_fort &
437 & (lfi, krep, krang, krec, kzone, ldadon, kretin)
438 
439 END SUBROUTINE lfiecx64
440 
441 SUBROUTINE lfiecx &
442 & (krep, krang, krec, kzone, ldadon, kretin)
443 USE lfimod, ONLY : lfi => lficom_default, &
444 & lficom_default_init, &
445 & new_lfi_default
446 USE lfi_precision
447 IMPLICIT NONE
448 ! Arguments
449 INTEGER (KIND=JPLIKM) KREP ! OUT
450 INTEGER (KIND=JPLIKM) KRANG ! IN
451 INTEGER (KIND=JPLIKM) KREC ! IN
452 INTEGER (KIND=JPLIKB) KZONE (*) ! IN
453 LOGICAL LDADON ! IN
454 INTEGER (KIND=JPLIKM) KRETIN ! OUT
455 
456 IF (.NOT. lficom_default_init) CALL new_lfi_default ()
457 
458 CALL lfiecx_mt &
459 & (lfi, krep, krang, krec, kzone, ldadon, kretin)
460 
461 END SUBROUTINE lfiecx
462 
463 SUBROUTINE lfiecx_mt &
464 & (lfi, krep, krang, krec, kzone, ldadon, kretin)
465 USE lfimod, ONLY : lficom
466 USE lfi_precision
467 IMPLICIT NONE
468 ! Arguments
469 type(lficom) lfi ! INOUT
470 INTEGER (KIND=JPLIKM) KREP ! OUT
471 INTEGER (KIND=JPLIKM) KRANG ! IN
472 INTEGER (KIND=JPLIKM) KREC ! IN
473 INTEGER (KIND=JPLIKB) KZONE (lfi%jplarx) ! IN
474 LOGICAL LDADON ! IN
475 INTEGER (KIND=JPLIKM) KRETIN ! OUT
476 ! Local integers
477 INTEGER (KIND=JPLIKB) IREP ! OUT
478 INTEGER (KIND=JPLIKB) IRANG ! IN
479 INTEGER (KIND=JPLIKB) IREC ! IN
480 INTEGER (KIND=JPLIKB) IRETIN ! OUT
481 ! Convert arguments
482 
483 irang = int( krang, jplikb)
484 irec = int( krec, jplikb)
485 
486 CALL lfiecx_fort &
487 & (lfi, irep, irang, irec, kzone, ldadon, iretin)
488 
489 krep = int( irep, jplikm)
490 kretin = int( iretin, jplikm)
491 
492 END SUBROUTINE lfiecx_mt
493 
494 !INTF KREP OUT
495 !INTF KRANG IN
496 !INTF KREC IN
497 !INTF KZONE IN DIMS=LFI%JPLARX KIND=JPLIKB
498 !INTF LDADON IN
499 !INTF KRETIN OUT
lfiecc_fort
subroutine lfiecc_fort(LFI, KREP, KNUMER, KREC, CDTAB, KNBECR, KFACTM, YDFIC, KRETIN)
Definition: lfiecc.F90:6
lfi_precision::jplikb
integer, parameter jplikb
Definition: lfi_precision.F90:25
lfiecx_fort
subroutine lfiecx_fort(LFI, KREP, KRANG, KREC, KZONE, LDADON, KRETIN)
Definition: lfiecx.F90:6
yomhook::dr_hook
Definition: yomhook.F90:20
lfirec_fort
subroutine lfirec_fort(LFI, KRGPIF, KRANG, KREC)
Definition: lfirec.F90:5
lfimod::new_lfi_default
subroutine new_lfi_default()
Definition: lfimod.F90:376
lfiecx
subroutine lfiecx(KREP, KRANG, KREC, KZONE, LDADON, KRETIN)
Definition: lfiecx.F90:443
lfimod::lficom_default_init
logical, save lficom_default_init
Definition: lfimod.F90:371
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
lfimod::lficom_default
type(lficom), target, save lficom_default
Definition: lfimod.F90:370
lfiecx64
subroutine lfiecx64(KREP, KRANG, KREC, KZONE, LDADON, KRETIN)
Definition: lfiecx.F90:421
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
lfi_precision::jplikm
integer, parameter jplikm
Definition: lfi_precision.F90:25
lfiems_fort
subroutine lfiems_fort(LFI, KNUMER, KNIMES, KCODE, LDFATA, CDMESS, CDNSPR, CDACTI)
Definition: lfiems.F90:7
lfimod
Definition: lfimod.F90:1
lfiecx_mt
subroutine lfiecx_mt(LFI, KREP, KRANG, KREC, KZONE, LDADON, KRETIN)
Definition: lfiecx.F90:465
lfiedo_fort
subroutine lfiedo_fort(LFI, KREP, KNUMER, KREC, KTAB, KNBECR, KFACTM, YDFIC, KRETIN)
Definition: lfiedo.F90:6
lfi_precision
Definition: lfi_precision.F90:1
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13