SURFEX v8.1
General documentation of Surfex
farpar.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 farpar_fort &
4 & (fa, krep, cdpref, cdsuff, kcodpa, knum)
5 USE fa_mod, ONLY : fa_com, jpniil, fagr1tab
6 USE parkind1, ONLY : jprb
7 USE yomhook , ONLY : lhook, dr_hook
8 USE lfi_precision
9 IMPLICIT NONE
10 !****
11 ! Sous-programme de reglage de la correspondance "nom d'article FA"
12 ! <-> "descripteurs GRIB du parametre+niveau"
13 !**
14 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
15 ! ( Tableau ) CDPREF (Entree) ==> Prefixe pour les KNUM noms d'article;
16 ! ( Tableau ) CDSUFF (Entree) ==> Suffixe pour les KNUM noms d'article;
17 ! ( Tableau ) KCODPA (Entree) ==> 6 descripteurs GRIB pour chacun
18 ! des KNUM parametres:
19 ! KCODPA(J,1) = KSEC1(1) version de la table parametres
20 ! KCODPA(J,2) = KSEC1(6) indicateur du parametre
21 ! KCODPA(J,3) = KSEC1(7) indicateur du type de niveau
22 ! KCODPA(J,4) = KSEC1(8) niveau
23 ! KCODPA(J,5) = KSEC1(9) 2ieme nv si couche, sinon 0
24 ! KCODPA(J,6) = KSEC1(18) indicateur du type de champ
25 ! (0 sf si min/max:2 ou si cumul:4)
26 !
27 ! KNUM (Entree ==> Nombre de parametres a regler
28 ! et (dimension de CDPREF, CDSUFF et KCODPA)
29 ! Sortie) ==> Nb de nouveaux parametres pouvant encore
30 ! etre definis lors d'un appel ulterieur.
31 !
32 !
33 !
34 TYPE(fa_com) :: FA
35 INTEGER (KIND=JPLIKB) KREP, KNUM
36 INTEGER (KIND=JPLIKB) KCODPA(knum,8)
37 !
38 CHARACTER (LEN=*) CDPREF(knum), CDSUFF(knum)
39 !
40 type(fagr1tab), POINTER :: ylgr1tab(:)
41 !
42 INTEGER (KIND=JPLIKB) J, JJ, INUMER, INIMES, JMEM, IMEM (knum), IADD
43 CHARACTER(LEN=FA%JPLMES) CLMESS
44 CHARACTER(LEN=FA%JPLSPX) CLNSPR
45 
46 !
47 INTRINSIC len_trim
48 !
49 !**
50 ! 0. - CONTROLES ET INITIALISATIONS PREALABLES
51 !-----------------------------------------------------------------------
52 !
53 REAL(KIND=JPRB) :: ZHOOK_HANDLE
54 IF (lhook) CALL dr_hook('FARPAR_MT',0,zhook_handle)
55 IF (knum.LT.1) THEN
56  krep=-129
57  IF (fa%LFAMOP) THEN
58  WRITE (unit=fa%NULOUT,fmt=*) &
59 & 'FARPAR: Nb de parametres ',knum,' incorrect'
60  ENDIF
61  GOTO 1001
62 ENDIF
63 DO j = 1,knum
64  IF ( int(len_trim(cdpref(j)), jplikb).LE.0 .OR. &
65 & int(len_trim(cdpref(j)), jplikb).GT.fa%JPXPRF ) THEN
66  krep=-129
67  IF (fa%LFAMOP) THEN
68  WRITE (unit=fa%NULOUT,fmt=*) &
69 & 'FARPAR: Longueur du prefixe ',cdpref(j), &
70 & ' incorrecte : ',int(len_trim(cdpref(j)), jplikb)
71  ENDIF
72  GOTO 1001
73  ENDIF
74  IF ( int(len_trim(cdsuff(j)), jplikb).LE.0 .OR. &
75 & int(len_trim(cdsuff(j)), jplikb).GT.fa%JPXNOM- &
76 & int(len_trim(cdpref(j)), jplikb) ) THEN
77  krep=-129
78  IF (fa%LFAMOP) THEN
79  WRITE (unit=fa%NULOUT,fmt=*) &
80 & 'FARPAR: Longueur du suffixe ',cdsuff(j), &
81 & ' incorrecte : ',int(len_trim(cdsuff(j)), jplikb)
82  ENDIF
83  GOTO 1001
84  ENDIF
85  DO jj = 1,3
86  IF (kcodpa(j,jj).LT.1 .OR. kcodpa(j,jj).GT.255) THEN
87  krep=-129
88  IF (fa%LFAMOP) THEN
89  WRITE (unit=fa%NULOUT,fmt=*) &
90 & 'FARPAR: descripteur GRIB num ',jj, &
91 & ' pour le parametre num ',j,' ( ', &
92 & cdpref(j)//cdsuff(j),' ) incorrect : ', &
93 & kcodpa(j,jj)
94  ENDIF
95  GOTO 1001
96  ENDIF
97  ENDDO
98  IF (kcodpa(j,6).LT.0 .OR. kcodpa(j,6).GT.124) THEN
99  krep=-129
100  IF (fa%LFAMOP) THEN
101  WRITE (unit=fa%NULOUT,fmt=*) &
102 & 'FARPAR: descripteur GRIB, KSEC1(18),', &
103 & ' pour le parametre num ',j,' ( ', &
104 & cdpref(j)//cdsuff(j),' ) incorrect : ', &
105 & kcodpa(j,6)
106  ENDIF
107  GOTO 1001
108  ENDIF
109  IF (kcodpa(j,4).LT.0) THEN
110  krep=-129
111  IF (fa%LFAMOP) THEN
112  WRITE (unit=fa%NULOUT,fmt=*) &
113 & 'FARPAR: descripteur GRIB, KSEC1(8),', &
114 & ' pour le parametre num ',j,' ( ', &
115 & cdpref(j)//cdsuff(j),' ) incorrect : ', &
116 & kcodpa(j,4)
117  ENDIF
118  GOTO 1001
119  ENDIF
120 ENDDO
121 !
122 !**
123 ! 2. - Prise en compte des nouvelles correspondances
124 !---------------------------------------------------------
125 !
126 !
127 
128 iadd=0
129 
130 DO j = 1,knum
131 ! Recherche prealable de l'eventuelle existence de la definition
132 ! de ce parametre (il faudra alors l'ecraser).
133  jmem = 0
134  DO jj = 1,fa%NBPARC
135  IF (cdpref(j)(1:int(len_trim(cdpref(j )), jplikb)).EQ.fa%YGR1TAB(jj)%CIPREF(1:int(len_trim(fa%YGR1TAB(jj)%CIPREF), jplikb)) &
136  & .AND. &
137  & cdsuff(j)(1:int(len_trim(cdsuff(j )), jplikb)).EQ.fa%YGR1TAB(jj)%CISUFF(1:int(len_trim(fa%YGR1TAB(jj)%CISUFF), jplikb))) &
138  THEN
139  jmem = jj
140  EXIT
141  ENDIF
142  ENDDO
143  IF (jmem==0) THEN
144  iadd = iadd + 1
145  imem(j) = fa%NBPARC + iadd
146  ELSE
147  imem(j) = jmem
148  ENDIF
149 ENDDO
150 
151 IF (iadd > 0) THEN
152  ylgr1tab => fa%YGR1TAB
153  ALLOCATE (fa%YGR1TAB (fa%NBPARC+iadd))
154  fa%YGR1TAB (1:fa%NBPARC) = ylgr1tab(1:fa%NBPARC)
155  fa%NBPARC = fa%NBPARC+iadd
156  DEALLOCATE (ylgr1tab)
157 ENDIF
158 
159 DO j = 1, knum
160 
161  jmem = imem(j)
162 
163  fa%YGR1TAB(jmem)%CIPREF = cdpref(j)(1:int(len_trim(cdpref(j)), jplikb))
164  fa%YGR1TAB(jmem)%CISUFF = cdsuff(j)(1:int(len_trim(cdsuff(j)), jplikb))
165  fa%YGR1TAB(jmem)%NCODPA(1:8) = kcodpa(j,1:8)
166 
167  IF (fa%LFAMOP) THEN
168  WRITE (unit=fa%NULOUT,fmt=*) &
169 & 'FARPAR: Prise en compte de ',cdpref(j)//cdsuff(j)
170  WRITE (unit=fa%NULOUT,fmt=*) &
171 & ' associe a KSEC1(1,6:9 et 18) = ', &
172 & fa%YGR1TAB(jmem)%NCODPA(1:8)
173  ENDIF
174 
175 ENDDO
176 !
177 !**
178 ! 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
179 ! VIA LE SOUS-PROGRAMME "FAIPAR" .
180 !-----------------------------------------------------------------------
181 !
182 1001 CONTINUE
183 !
184 IF (fa%LFAMOP) THEN
185  inimes=2
186  clnspr='FARPAR'
187  inumer=jpniil
188 !
189  WRITE (unit=clmess,fmt='(''KREP='',I4)') krep
190  CALL faipar_fort &
191 & (fa, inumer,inimes,krep,.false.,clmess, &
192 & clnspr,clnspr,.false.)
193 ENDIF
194 !
195 IF (lhook) CALL dr_hook('FARPAR_MT',1,zhook_handle)
196 END SUBROUTINE farpar_fort
197 
198 
199 
200 ! Oct-2012 P. Marguinaud 64b LFI
201 SUBROUTINE farpar64 &
202 & (krep, cdpref, cdsuff, kcodpa, knum)
203 USE fa_mod, ONLY : fa => fa_com_default, &
204 & fa_com_default_init, &
205 & new_fa_default
206 USE lfi_precision
207 IMPLICIT NONE
208 ! Arguments
209 INTEGER (KIND=JPLIKB) KREP ! OUT
210 INTEGER (KIND=JPLIKB) KNUM ! IN
211 CHARACTER (LEN=*) CDPREF (knum) ! IN
212 CHARACTER (LEN=*) CDSUFF (knum) ! IN
213 INTEGER (KIND=JPLIKB) KCODPA (knum,7) ! IN
214 
215 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
216 
217 CALL farpar_fort &
218 & (fa, krep, cdpref, cdsuff, kcodpa, knum)
219 
220 END SUBROUTINE farpar64
221 
222 SUBROUTINE farpar &
223 & (krep, cdpref, cdsuff, kcodpa, knum)
224 USE fa_mod, ONLY : fa => fa_com_default, &
225 & fa_com_default_init, &
226 & new_fa_default
227 USE lfi_precision
228 IMPLICIT NONE
229 ! Arguments
230 INTEGER (KIND=JPLIKM) KREP ! OUT
231 INTEGER (KIND=JPLIKM) KNUM ! IN
232 CHARACTER (LEN=*) CDPREF (knum) ! IN
233 CHARACTER (LEN=*) CDSUFF (knum) ! IN
234 INTEGER (KIND=JPLIKM) KCODPA (knum,7) ! IN
235 
236 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
237 
238 CALL farpar_mt &
239 & (fa, krep, cdpref, cdsuff, kcodpa, knum)
240 
241 END SUBROUTINE farpar
242 
243 SUBROUTINE farpar_mt &
244 & (fa, krep, cdpref, cdsuff, kcodpa, knum)
245 USE fa_mod, ONLY : fa_com
246 USE lfi_precision
247 IMPLICIT NONE
248 ! Arguments
249 type(fa_com) fa ! INOUT
250 INTEGER (KIND=JPLIKM) KREP ! OUT
251 INTEGER (KIND=JPLIKM) KNUM ! IN
252 CHARACTER (LEN=*) CDPREF (knum) ! IN
253 CHARACTER (LEN=*) CDSUFF (knum) ! IN
254 INTEGER (KIND=JPLIKM) KCODPA (knum,7) ! IN
255 ! Local integers
256 INTEGER (KIND=JPLIKB) IREP ! OUT
257 INTEGER (KIND=JPLIKB) ICODPA (knum,7) ! IN
258 INTEGER (KIND=JPLIKB) INUM ! INOUT
259 ! Convert arguments
260 
261 icodpa = int( kcodpa, jplikb)
262 inum = int( knum, jplikb)
263 
264 CALL farpar_fort &
265 & (fa, irep, cdpref, cdsuff, icodpa, inum)
266 
267 krep = int( irep, jplikm)
268 
269 END SUBROUTINE farpar_mt
270 
271 !INTF KREP OUT
272 !INTF CDPREF IN DIMS=KNUM
273 !INTF CDSUFF IN DIMS=KNUM
274 !INTF KCODPA IN DIMS=KNUM,7
275 !INTF KNUM IN
276 
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
farpar_mt
subroutine farpar_mt(FA, KREP, CDPREF, CDSUFF, KCODPA, KNUM)
Definition: farpar.F90:245
fa_mod::new_fa_default
subroutine new_fa_default()
Definition: fa_mod.F90:649
fa_mod::fagr1tab
Definition: fa_mod.F90:241
fa_mod
Definition: fa_mod.F90:1
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
farpar
subroutine farpar(KREP, CDPREF, CDSUFF, KCODPA, KNUM)
Definition: farpar.F90:224
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
farpar_fort
subroutine farpar_fort(FA, KREP, CDPREF, CDSUFF, KCODPA, KNUM)
Definition: farpar.F90:5
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
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
farpar64
subroutine farpar64(KREP, CDPREF, CDSUFF, KCODPA, KNUM)
Definition: farpar.F90:203
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