SURFEX v8.1
General documentation of Surfex
chien.F90
Go to the documentation of this file.
1 SUBROUTINE chien(CDNAMC,KTYPTR,PSLAPO,PLOCEN,&
2  & PCODIL,KTRONC,KDGL,KNXLON,KNLOPA,KNOZPA,&
3  & KHTYP,KFLEV,PREF,PVALH,PVBH,KQUAD,KINF,&
4  & KDGSA,KDGEN,PEPS,LDFICP,KULOUT)
5 
6 !**** *CHIEN* - CHeck Input ENvironment
7 
8 ! Purpose.
9 ! --------
10 ! It controls coherence between defined geometry and ARPEGE
11 ! file. In the case of inconsistency it calls ABORT. This
12 ! routine could be also used in order to simply get full
13 ! information from the cadre.
14 
15 !** Interface.
16 ! ----------
17 ! *CALL* *CHIEN(CDNAMC,KTYPTR,PSLAPO,PLOCEN,
18 ! & PCODIL,KTRONC,KDGL,KNXLON,KNLOPA,KNOZPA,
19 ! & KHTYP,KFLEV,PREF,PVALH,PVBH,KQUAD,KINF,
20 ! & KDGSA,KDGEN,PEPS,LDFICP,KULOUT)
21 
22 ! Explicit arguments :
23 ! --------------------
24 
25 ! Input (Output case is now done in *RIEN*) :
26 ! ----------------------------
27 
28 ! CDNAMC ... Name of the cadre
29 
30 ! Determination of reference geometry:
31 
32 ! KTYPTR ... Type of Schmidt transform
33 ! 1 ===> Pole is at geog. North Pole
34 ! and stretching is equal to 1
35 ! 2 ===> General case
36 ! PSLAPO ... Sinus latitude of pole of dilatation
37 ! PLOCEN ... Longitude of pole of dilatation
38 ! PCODIL ... Stretching factor
39 ! KTRONC ... Truncation
40 ! KDGL ... Number of latitudes without poles
41 ! KNXLON ... Max. number of longitudes at a parallel
42 ! KNLOPA ... Number of longitudes at a parallel
43 ! KNOZPA ... Max. wave number at a parallel
44 ! KHTYP ... Type of collocation grid
45 ! 0 ==> regular grid
46 ! 2 ==> reduced grid towards the poles
47 ! KFLEV ... Number of vertical levels
48 ! PREF ... Reference pressure
49 ! PVALH ... "A" coefficients of vertical system
50 ! PVBH ... "B" coefficients of vertical system
51 ! KQUAD ... Quadrature ( 1 : Gauss ; 2 : Lobatto)
52 ! LDFICP ... .TRUE. if file contains the poles
53 ! -----------------------------------------------------------------
54 ! Input :
55 ! -------
56 
57 ! KDGSA ... First row of arrays KNLOPA and KNOZPA
58 ! KDGEN ... Last row of arrays KNLOPA and KNOZPA
59 ! PEPS ... Precision of the tests on real variables
60 ! KINF ... Key:
61 ! -1 ==> Minimum checks for climate file
62 ! and call abort; if O.K. it
63 ! gives back LDFICP
64 ! 0 ==> Check and call abort; if O.K. it
65 ! gives back LDFICP
66 ! 1 ==> Simply gives back full information
67 ! KULOUT ... Output file unit
68 ! -----------------------------------------------------------------
69 
70 ! -----------------------------------------------------------------
71 
72 ! Implicit arguments :
73 ! --------------------
74 ! None.
75 
76 ! Method.
77 ! -------
78 ! See documentation
79 
80 ! Externals.
81 ! ----------
82 
83 ! Reference.
84 ! ----------
85 ! ARPEGE/ALADIN Documentation.
86 ! Document 'Control of coherence between namelist and Arpege File'
87 ! by R. El Khatib
88 
89 ! Author.
90 ! -------
91 ! Radmila Bubnova *GMAP/COMPAS - stage MICECO*
92 
93 ! Remark.
94 ! -------
95 !****** This routine is a small christmas gift for our friend
96 !****** Ryad El Khatib **************************************
97 ! (hopefully without too much bugs)
98 
99 ! Modifications.
100 ! --------------
101 ! Original : 91-12-10
102 ! R El Khatib : 92-02-07
103 ! R El Khatib : 92-06-01 (option KINF=-1)
104 ! M Hamrud : 92-10-01 (NHTYP=2)
105 ! R El Khatib : 93-03-03 (NHTYP=2 recoded)
106 ! R El Khatib : 93-05-04 (KNOZPA NOT tested when KINF=-1)
107 ! R El Khatib : 97-07-22 (Deep cleanup)
108 ! K. YESSAD : 98-08-10 removal of LRPOLE option.
109 ! -> LDPOLE, LLPOLE become .false. and disappear.
110 ! R El Khatib : 99-09-02 (KNOZPA NOW tested again when KINF=-1)
111 ! M.Hamrud : 01-Oct-2003 CY28 Cleaning
112 ! R El Khatib : 05-03-01 Cleanups
113 ! O. Marsden : May 2016 Moved the KINF==1 case to a new routine (RIEN)
114 ! and changed argument intents to IN wherever possible
115 ! ------------------------------------------------------------------
116 
117 USE parkind1 ,ONLY : jpim ,jprb
118 USE yomhook ,ONLY : lhook, dr_hook
119 
120 ! ------------------------------------------------------------------
121 
122 IMPLICIT NONE
123 
124 INTEGER(KIND=JPIM),INTENT(IN) :: KFLEV
125 INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA
126 INTEGER(KIND=JPIM),INTENT(IN) :: KDGEN
127 CHARACTER(LEN=16) ,INTENT(IN) :: CDNAMC
128 INTEGER(KIND=JPIM),INTENT(IN) :: KTYPTR
129 REAL(KIND=JPRB) ,INTENT(IN) :: PSLAPO
130 REAL(KIND=JPRB) ,INTENT(IN) :: PLOCEN
131 REAL(KIND=JPRB) ,INTENT(IN) :: PCODIL
132 INTEGER(KIND=JPIM),INTENT(IN) :: KTRONC
133 INTEGER(KIND=JPIM),INTENT(IN) :: KDGL
134 INTEGER(KIND=JPIM),INTENT(IN) :: KNXLON
135 INTEGER(KIND=JPIM),INTENT(IN) :: KNLOPA(kdgsa:kdgen)
136 INTEGER(KIND=JPIM),INTENT(IN) :: KNOZPA(kdgsa:kdgen)
137 INTEGER(KIND=JPIM),INTENT(IN) :: KHTYP
138 REAL(KIND=JPRB) ,INTENT(IN) :: PREF
139 REAL(KIND=JPRB) ,INTENT(IN) :: PVALH(0:kflev)
140 REAL(KIND=JPRB) ,INTENT(IN) :: PVBH(0:kflev)
141 INTEGER(KIND=JPIM),INTENT(IN) :: KQUAD
142 INTEGER(KIND=JPIM),INTENT(IN) :: KINF
143 REAL(KIND=JPRB) ,INTENT(IN) :: PEPS
144 LOGICAL ,INTENT(OUT) :: LDFICP
145 INTEGER(KIND=JPIM),INTENT(IN) :: KULOUT
146 
147 ! ------------------------------------------------------------------
148 
149 INTEGER(KIND=JPIM), ALLOCATABLE :: INLOPA(:),INOZPA(:)
150 REAL(KIND=JPRB), ALLOCATABLE :: ZVALH(:),ZVBH(:)
151 REAL(KIND=JPRB), ALLOCATABLE :: ZSINLA(:)
152 LOGICAL :: LLGARD
153 
154 INTEGER(KIND=JPIM) :: IDGL, IDGNH, IERR, IERRA, IHTYP, INIVER, INLATI, &
155  & INXLON, IQUADF, ISTROW, ITRONC, ITYPTR, JFLEV, JL, JLAT, JLEV, IMAXLEV, &
156  & IMAXGL, IMAXLON, IMAXTRUNC
157 
158 REAL(KIND=JPRB) :: ZCLOPO, ZCODIL, ZEPS, ZMUNPOL, ZREF, ZSLAPO, ZSLOPO, ZX1
159 REAL(KIND=JPRB) :: ZX2
160 REAL(KIND=JPRB) :: ZHOOK_HANDLE
161 
162 ! ------------------------------------------------------------------
163 
164 #include "abor1.intfb.h"
165 
166 ! ------------------------------------------------------------------
167 
168 IF (lhook) CALL dr_hook('CHIEN',0,zhook_handle)
169 
170 ! ------------------------------------------------------------------
171 
172 !* 0. Get software limits
173 ! -------------------
174 
175 CALL falimu(imaxlev,imaxtrunc,imaxgl,imaxlon)
176 ALLOCATE(inlopa(imaxgl))
177 ALLOCATE(inozpa(imaxgl))
178 ALLOCATE(zsinla(imaxgl))
179 ALLOCATE(zvalh(0:imaxlev))
180 ALLOCATE(zvbh(0:imaxlev))
181 
182 !* 1. Read file characteristics
183 ! -------------------------
184 
185 WRITE(kulout,*) ' HAF, HAF : CADRE : ',cdnamc
186 CALL facies(cdnamc,ityptr,zslapo,zclopo,zslopo,zcodil,itronc,&
187  & inlati,inxlon,inlopa,inozpa,zsinla,iniver,zref,zvalh,zvbh,llgard)
188 
189 IF (kinf == 1) THEN
190  IF (inlati > kdgen-kdgsa+1) THEN
191  CALL abor1('CHIEN : MAX. NUMBER OF LATITUDE ROWS IN MODEL TOO SMALL !')
192  ENDIF
193  IF (iniver > kflev) THEN
194  CALL abor1('CHIEN : MAX. NUMBER OF LEVEL IN MODEL TOO SMALL !')
195  ENDIF
196 ENDIF
197 
198 !* 2. Preliminary tests
199 ! -----------------
200 
201 ! Test - type of file
202 
203 IF(ityptr < 0) THEN
204  WRITE(kulout,*) 'YOU ARE USING A FILE ALADIN ',&
205  & 'WHILE THE MODEL EXPECTS A FILE ARPEGE'
206  CALL abor1('CHIEN: ABOR1 CALLED 2a')
207 ENDIF
208 
209 ! Test - type of collocation grid
210 
211 IF(inlopa(1) == inlopa(int(inlati/2))) THEN
212  ihtyp = 0
213  WRITE(kulout,*) 'FILE HAS REGULAR GRID '
214 ELSE
215  ihtyp = 2
216  WRITE(kulout,*) 'FILE HAS REDUCED GRID '
217 ENDIF
218 
219 ! Poles story
220 
221 zmunpol = 0.9999999999_jprb
222 IF(zsinla(1) >= zmunpol) THEN
223  WRITE(kulout,*) ' FILE CONTAINS THE POLES '
224  ldficp = .true.
225  idgl = inlati - 2
226  idgnh = (idgl+1)/2
227 ! The following test ensures that the fields of the file
228 ! will be read properly :
229  IF(inlopa(1) /= inlopa(2)) THEN
230  WRITE(kulout,*) ' FILE ROWS #1 AND #2 DO NOT HAVE THE ',&
231  & 'SAME NUMBER OF LONGITUDES'
232  WRITE(kulout,*) ' THIS MAKES THE MODEL UNABLE TO READ THE '&
233  & ,'FILE PROPERLY'
234  CALL abor1('CHIEN: ABOR1 CALLED 2b')
235  ENDIF
236 ELSE
237  WRITE(kulout,*) ' FILE DOES NOT CONTAINS THE POLES '
238  ldficp = .false.
239  idgl = inlati
240  idgnh = (idgl+1)/2
241 ENDIF
242 
243 ! Test - Gaussian or Lobatto truncation
244 
245 IF(ldficp) THEN
246  zx1 = 1.0_jprb - zsinla(2)
247  zx2 = zsinla(2) - zsinla(3)
248  IF (zx1 > zx2) THEN
249  iquadf = 2
250  WRITE(kulout,*) 'FILE HAS LOBATTO QUADRATURE'
251  IF(mod(inlati,2) == 0) THEN
252  WRITE(kulout,*) ' WARNING ! INLATI IS EVEN !'
253  ENDIF
254  ELSE
255  iquadf = 1
256  WRITE(kulout,*) 'FILE HAS GAUSSIAN QUADRATURE'
257  IF(mod(inlati,2) == 1) THEN
258  WRITE(kulout,*) ' WARNING ! INLATI IS ODD !'
259  ENDIF
260  ENDIF
261 ELSE
262  iquadf = 1
263  WRITE(kulout,*) 'FILE HAS GAUSSIAN QUADRATURE'
264  IF(mod(inlati,2) == 1) THEN
265  WRITE(kulout,*) ' WARNING ! INLATI IS ODD !'
266  ENDIF
267 ENDIF
268 
269 IF ((kinf == 0).OR.(kinf == -1)) THEN
270 
271 !* 3. Checklist
272 ! ---------
273 
274  ierr=0
275 
276 !* 3.1 Spectral dimensions
277 
278  IF(itronc /= ktronc) THEN
279  WRITE(kulout,*) ' TRUNCATION MISMATCH : '&
280  & ,'FILE = ',itronc, ' ; ARGUMENT = ',ktronc
281  ierr=1
282  ENDIF
283 
284 !* 3.2 Spectral-related dimensions
285 
286  IF(inxlon /= knxlon) THEN
287  WRITE(kulout,*) ' MAX. NUMBER OF LONGITUDES MISMATCH : '&
288  & ,'FILE = ',inxlon, ' ; ARGUMENT = ',knxlon
289  ierr=1
290  ENDIF
291  IF (ldficp) THEN
292  IF(inlati /= (kdgl+2)) THEN
293  WRITE(kulout,*) 'MAX. NUMBER OF LATITUDES MISMATCH : '&
294  & ,'FILE = ',inlati, ' INCLUDING POLES ; ARGUMENT = ',kdgl
295  ierr=1
296  ELSE
297  istrow=1
298  DO jlat = istrow, (inlati-1)/2
299  IF(knlopa(jlat) /= inlopa(jlat+1)) THEN
300  WRITE(kulout,*) ' NUMBER OF LONGITUDES MISMATCH ON ',&
301  & 'ROW ',jlat,' : ', &
302  & 'FILE = ',inlopa(jlat+1), ' ; ARGUMENT = ',knlopa(jlat)
303  ierr=1
304  ENDIF
305  IF(knozpa(jlat) /= inozpa(jlat+1)) THEN
306  WRITE(kulout,*) ' WAVES NUMBER MISMATCH ON ',&
307  & 'ROW ',jlat,' : ', &
308  & 'FILE = ',inozpa(jlat+1), ' ; ARGUMENT = ',knozpa(jlat)
309  ierr=1
310  ENDIF
311  ENDDO
312  ENDIF
313  ELSE
314  IF(inlati /= (kdgl)) THEN
315  WRITE(kulout,*) 'NUMBER OF LATITUDES MISMATCH : '&
316  & ,'FILE = ',inlati, ' (NO POLES) ; ARGUMENT = ',kdgl
317  ierr=1
318  ELSE
319  DO jlat = 1, (inlati+1)/2
320  IF(knlopa(jlat) /= inlopa(jlat)) THEN
321  WRITE(kulout,*) ' NUMBER OF LONGITUDES MISMATCH ON ',&
322  & 'ROW ',jlat,' : ', &
323  & 'FILE = ',inlopa(jlat), ' ; ARGUMENT = ',knlopa(jlat)
324  ierr=1
325  ENDIF
326  IF(knozpa(jlat) /= inozpa(jlat)) THEN
327  WRITE(kulout,*) ' WAVES NUMBER MISMATCH ON ',&
328  & 'ROW ',jlat,' : ', &
329  & 'FILE = ',inozpa(jlat), ' ; ARGUMENT = ',knozpa(jlat)
330  ierr=1
331  ENDIF
332  ENDDO
333  ENDIF
334  ENDIF
335 
336 !* 3.3 Horizontal geometry
337 
338  IF(ihtyp /= khtyp) THEN
339  WRITE(kulout,*) ' HORIZONTAL GRID MISMATCH : '&
340  & ,'FILE = ',ihtyp, ' ; ARGUMENT = ',khtyp
341  ierr=1
342  ENDIF
343  IF(ityptr /= ktyptr) THEN
344  WRITE(kulout,*) ' TRANSFORMATION MISMATCH : '&
345  & ,'FILE = ',ityptr, ' ; ARGUMENT = ',ktyptr
346  ierr=1
347  ENDIF
348  IF(abs(pslapo-zslapo) > peps) THEN
349  WRITE(kulout,*) ' SINE OF LATITUDE OF POLE MISMATCH : '&
350  & ,'FILE = ',zslapo, ' ; ARGUMENT = ',pslapo
351  ierr=1
352  ENDIF
353  IF(abs(cos(plocen)-zclopo) > peps) THEN
354  WRITE(kulout,*) ' COSINE OF LONGITUDE OF POLE MISMATCH : '&
355  & ,'FILE = ',zclopo, ' ; ARGUMENT = ',cos(plocen)
356  ierr=1
357  ENDIF
358  IF(abs(sin(plocen)-zslopo) > peps) THEN
359  WRITE(kulout,*) ' SINE OF LONGITUDE OF POLE MISMATCH : '&
360  & ,'FILE = ',zslopo, ' ; ARGUMENT = ',sin(plocen)
361  ierr=1
362  ENDIF
363  IF(abs(zcodil-pcodil) > peps) THEN
364  WRITE(kulout,*) ' STRETCHING MISMATCH : '&
365  & ,'FILE = ',zcodil, ' ; ARGUMENT = ',pcodil
366  ierr=1
367  ENDIF
368  IF(kquad /= iquadf) THEN
369  WRITE(kulout,*) ' QUADRATURE MISMATCH : ',&
370  & 'FILE = ',iquadf, ' ; ARGUMENT = ',kquad
371  ierr=1
372  ENDIF
373 
374 !* 3.4 Vertical levels
375 
376  IF (kinf == 0) THEN
377  IF(iniver /= kflev) THEN
378  WRITE(kulout,*) ' NUMBER OF LEVELS MISMATCH : '&
379  & ,'FILE = ',iniver, ' ; ARGUMENT = ',kflev
380  ierr=1
381  ELSE
382  zeps=peps*10._jprb*max(zref,pref)
383  ierra=0
384  DO jflev = 0,kflev
385  IF(abs(zvalh(jflev)*zref-pvalh(jflev)*pref) > zeps) THEN
386  WRITE(kulout,*) ' VERTICAL FUNCTION *A* MISMATCH ON ',&
387  & 'LEVEL ',jflev,' : ',&
388  & 'FILE = ',zvalh(jflev), ' ; ARGUMENT = ',pvalh(jflev)
389  ierra=1
390  ierr=1
391  ENDIF
392  IF(abs(zvbh(jflev)-pvbh(jflev)) > peps) THEN
393  WRITE(kulout,*) ' VERTICAL FUNCTION *B* MISMATCH ON ',&
394  & 'LEVEL ',jflev,' : ',&
395  & 'FILE = ',zvbh(jflev), ' ; ARGUMENT = ',pvbh(jflev)
396  ierr=1
397  ENDIF
398  ENDDO
399  IF (ierra /= 0) THEN
400  WRITE(kulout,*) ' REFERENCE PRESSURE : ',&
401  & 'FILE = ',zref, ' ; ARGUMENT = ',pref
402  ENDIF
403  ENDIF
404  ENDIF
405 
406  IF(ierr /= 0) THEN
407  CALL abor1('CHIEN: ABOR1 CALLED 3.4')
408  ENDIF
409 
410 ELSEIF(kinf == 1) THEN
411 
412  WRITE(kulout,*) 'CHIEN ERROR : CHIEN(..., KINF=1,...) HAS BEEN REPLACED BY RIEN(...)'
413  CALL abor1('CHIEN: ABOR1 CALLED 4.1')
414 
415 ELSE
416  WRITE(kulout,*) 'INTERNAL ERROR : KINF=',kinf
417  CALL abor1('CHIEN: ABOR1 CALLED 4.2')
418 ENDIF
419 
420 DEALLOCATE(inlopa)
421 DEALLOCATE(inozpa)
422 DEALLOCATE(zsinla)
423 DEALLOCATE(zvalh)
424 DEALLOCATE(zvbh)
425 
426 ! ------------------------------------------------------------------
427 
428 IF (lhook) CALL dr_hook('CHIEN',1,zhook_handle)
429 END SUBROUTINE chien
430 
parkind1::jpim
integer, parameter jpim
Definition: parkind1.F90:13
abor1
subroutine abor1(CDTEXT)
Definition: abor1.F90:2
falimu
subroutine falimu(KXNIVV, KXTRON, KXLATI, KXLONG)
Definition: falimu.F90:115
yomhook::dr_hook
Definition: yomhook.F90:20
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
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
chien
subroutine chien(CDNAMC, KTYPTR, PSLAPO, PLOCEN, PCODIL, KTRONC, KDGL, KNXLON, KNLOPA, KNOZPA, KHTYP, KFLEV, PREF, PVALH, PVBH, KQUAD, KINF, KDGSA, KDGEN, PEPS, LDFICP, KULOUT)
Definition: chien.F90:5
Generated on Tue Jan 16 2018 16:23:22 for SURFEX v8.1 by   doxygen 1.8.13