source: LMDZ4/branches/IPSL-CM4_IPCC_patches/libf/dyn3d/fxhyp.F @ 5451

Last change on this file since 5451 was 524, checked in by lmdzadmin, 21 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.6 KB
Line 
1!
2! $Header$
3!
4c
5c
6       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzoom,tau ,
7     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
8     , champmin,champmax                                               )
9
10c      Auteur :  P. Le Van
11
12       IMPLICIT NONE
13
14c    Calcule les longitudes et derivees dans la grille du GCM pour une
15c     fonction f(x) a tangente  hyperbolique  .
16c
17c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.)
18c     dzoom  etant  la distance totale de la zone du zoom
19c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom
20c
21c    On doit avoir grossism x dzoom <  pi ( radians )   , en longitude.
22c   ********************************************************************
23
24
25       INTEGER nmax, nmax2
26       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
27c
28       LOGICAL scal180
29       PARAMETER ( scal180 = .TRUE. )
30
31c      scal180 = .TRUE.  si on veut avoir le premier point scalaire pour   
32c      une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres.
33c      sinon scal180 = .FALSE.
34
35#include "dimensions.h"
36#include "paramet.h"
37       
38c     ......  arguments  d'entree   .......
39c
40       REAL xzoomdeg,dzoom,tau,grossism
41
42c    ......   arguments  de  sortie  ......
43
44       REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
45     ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
46
47c     .... variables locales  ....
48c
49       REAL*8 xlon(iip1),xprimm(iip1),xuv
50       REAL*8 xtild(0:nmax2)
51       REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2)
52       REAL*8 Xf(0:nmax2),xxpr(0:nmax2)
53       REAL*8 xvrai(iip1),xxprim(iip1)
54       REAL*8 pi,depi,epsilon,xzoom,fa,fb
55       REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2
56       INTEGER i,it,ik,iter,ii,idif,ii1,ii2
57       REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin
58       REAL*8 champmin,champmax,decalx
59       INTEGER is2
60       SAVE is2
61
62       REAL*8 heavyside
63
64       pi       = 2. * ASIN(1.)
65       depi     = 2. * pi
66       epsilon  = 1.e-3
67       xzoom    = xzoomdeg * pi/180.
68c
69           decalx   = .75
70       IF( grossism.EQ.1..AND.scal180 )  THEN
71           decalx   = 1.
72       ENDIF
73
74       WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx
75c
76       IF( dzoom.LT.1.)  THEN
77         dzoom = dzoom * depi
78       ELSEIF( dzoom.LT. 25. ) THEN
79         WRITE(6,*) ' Le param. dzoomy pour fxhyp est trop petit ! L aug
80     ,menter et relancer ! '
81         STOP 1
82       ELSE
83         dzoom = dzoom * pi/180.
84       ENDIF
85
86       WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)'
87       WRITE(6,24) xzoom,grossism,tau,dzoom
88
89       DO i = 0, nmax2
90        xtild(i) = - pi + FLOAT(i) * depi /nmax2
91       ENDDO
92
93       DO i = nmax, nmax2
94
95       fa  = tau*  ( dzoom/2.  - xtild(i) )
96       fb  = xtild(i) *  ( pi - xtild(i) )
97
98         IF( 200.* fb .LT. - fa )   THEN
99           fhyp ( i) = - 1.
100         ELSEIF( 200. * fb .LT. fa ) THEN
101           fhyp ( i) =   1.
102         ELSE
103            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
104                IF(   200.*fb + fa.LT.1.e-10 )  THEN
105                    fhyp ( i ) = - 1.
106                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
107                    fhyp ( i )  =   1.
108                ENDIF
109            ELSE
110                    fhyp ( i )  =  TANH ( fa/fb )
111            ENDIF
112         ENDIF
113        IF ( xtild(i).EQ. 0. )  fhyp(i) =  1.
114        IF ( xtild(i).EQ. pi )  fhyp(i) = -1.
115
116       ENDDO
117
118cc  ....  Calcul  de  beta  ....
119
120       ffdx = 0.
121
122       DO i = nmax +1,nmax2
123
124       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
125       fa  = tau*  ( dzoom/2.  - xmoy )
126       fb  = xmoy *  ( pi - xmoy )
127
128       IF( 200.* fb .LT. - fa )   THEN
129         fxm = - 1.
130       ELSEIF( 200. * fb .LT. fa ) THEN
131         fxm =   1.
132       ELSE
133            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
134                IF(   200.*fb + fa.LT.1.e-10 )  THEN
135                    fxm   = - 1.
136                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
137                    fxm   =   1.
138                ENDIF
139            ELSE
140                    fxm   =  TANH ( fa/fb )
141            ENDIF
142       ENDIF
143
144       IF ( xmoy.EQ. 0. )  fxm  =  1.
145       IF ( xmoy.EQ. pi )  fxm  = -1.
146
147       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
148
149       ENDDO
150
151        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
152
153       IF( 2.*beta - grossism.LE. 0.)  THEN
154        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
155     ,tine fxhyp est mauvaise ! '
156        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
157     , ' et relancer ! ***  '
158        CALL ABORT
159       ENDIF
160c
161c   .....  calcul  de  Xprimt   .....
162c
163       
164       DO i = nmax, nmax2
165        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
166       ENDDO
167c   
168       DO i =  nmax+1, nmax2
169        Xprimt( nmax2 - i ) = Xprimt( i )
170       ENDDO
171c
172
173c   .....  Calcul  de  Xf     ........
174
175       Xf(0) = - pi
176
177       DO i =  nmax +1, nmax2
178
179       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
180       fa  = tau*  ( dzoom/2.  - xmoy )
181       fb  = xmoy *  ( pi - xmoy )
182
183       IF( 200.* fb .LT. - fa )   THEN
184         fxm = - 1.
185       ELSEIF( 200. * fb .LT. fa ) THEN
186         fxm =   1.
187       ELSE
188         fxm =  TANH ( fa/fb )
189       ENDIF
190
191       IF ( xmoy.EQ. 0. )  fxm =  1.
192       IF ( xmoy.EQ. pi )  fxm = -1.
193       xxpr(i)    = beta + ( grossism - beta ) * fxm
194
195       ENDDO
196
197       DO i = nmax+1, nmax2
198        xxpr(nmax2-i+1) = xxpr(i)
199       ENDDO
200
201        DO i=1,nmax2
202         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
203        ENDDO
204
205
206c    *****************************************************************
207c
208
209c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
210c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
211c
212      WRITE(6,18)
213c
214      DO 5000  ik = 1, 4
215
216       IF( ik.EQ.1 )        THEN
217         xuv =  -0.25
218       ELSE IF ( ik.EQ.2 )  THEN
219         xuv =   0.
220       ELSE IF ( ik.EQ.3 )  THEN
221         xuv =   0.50
222       ELSE IF ( ik.EQ.4 )  THEN
223         xuv =   0.25
224       ENDIF
225
226      xo1   = 0.
227
228      ii1=1
229      ii2=iim
230      IF(ik.EQ.1.and.grossism.EQ.1.) THEN
231        ii1 = 2
232        ii2 = iim+1
233      ENDIF
234      DO 1500 i = ii1, ii2
235
236      xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim)
237
238      Xfi    = xlon2
239c
240      DO 250 it =  nmax2,0,-1
241      IF( Xfi.GE.Xf(it))  GO TO 350
242250   CONTINUE
243
244      it = 0
245
246350   CONTINUE
247
248c    ......  Calcul de   Xf(xi)    ......
249c
250      xi  = xtild(it)
251
252      IF(it.EQ.nmax2)  THEN
253       it       = nmax2 -1
254       Xf(it+1) = pi
255      ENDIF
256c  .....................................................................
257c
258c   Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un
259c   polynome de degre 3  qui passe  par les points (Xf(it),xtild(it) )
260c          et (Xf(it+1),xtild(it+1) )
261
262       CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1),
263     ,                xtild(it),xtild(it+1),  a0, a1, a2, a3  )
264
265       Xf1     = Xf(it)
266       Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi
267
268       DO 500 iter = 1,300
269        xi = xi - ( Xf1 - Xfi )/ Xprimin
270
271        IF( ABS(xi-xo1).LE.epsilon)  GO TO 550
272         xo1      = xi
273         xi2      = xi * xi
274         Xf1      = a0 +  a1 * xi +     a2 * xi2  +     a3 * xi2 * xi
275         Xprimin  =       a1      + 2.* a2 *  xi  + 3.* a3 * xi2
276500   CONTINUE
277        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
278          STOP 6
279550   CONTINUE
280
281       xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
282       xvrai(i)  =  xi + xzoom
283
2841500   CONTINUE
285
286
287       IF(ik.EQ.1.and.grossism.EQ.1.)  THEN
288         xvrai(1)    = xvrai(iip1)-depi
289         xxprim(1)   = xxprim(iip1)
290       ENDIF
291       DO i = 1 , iim
292        xlon(i)     = xvrai(i)
293        xprimm(i)   = xxprim(i)
294       ENDDO
295       DO i = 1, iim -1
296        IF( xvrai(i+1). LT. xvrai(i) )  THEN
297         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
298     ,  ')'
299        STOP 7
300        ENDIF
301       ENDDO
302c
303c   ... Reorganisation  des  longitudes  pour les avoir  entre - pi et pi ..
304c   ........................................................................
305
306       champmin =  1.e12
307       champmax = -1.e12
308       DO i = 1, iim
309        champmin = MIN( champmin,xvrai(i) )
310        champmax = MAX( champmax,xvrai(i) )
311       ENDDO
312
313      IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 )  THEN
314                GO TO 1600
315      ELSE
316       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
317     ,  ' et pi '
318c
319        IF( xzoom.LE.0.)  THEN
320          IF( ik.EQ. 1 )  THEN
321          DO i = 1, iim
322           IF( xvrai(i).GE. - pi )  GO TO 80
323          ENDDO
324            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
325            STOP 8
326 80       CONTINUE
327          is2 = i
328          ENDIF
329
330          IF( is2.NE. 1 )  THEN
331            DO ii = is2 , iim
332             xlon  (ii-is2+1) = xvrai(ii)
333             xprimm(ii-is2+1) = xxprim(ii)
334            ENDDO
335            DO ii = 1 , is2 -1
336             xlon  (ii+iim-is2+1) = xvrai(ii) + depi
337             xprimm(ii+iim-is2+1) = xxprim(ii)
338            ENDDO
339          ENDIF
340        ELSE
341          IF( ik.EQ.1 )  THEN
342           DO i = iim,1,-1
343             IF( xvrai(i).LE. pi ) GO TO 90
344           ENDDO
345             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
346              STOP 9
347 90        CONTINUE
348            is2 = i
349          ENDIF
350           idif = iim -is2
351           DO ii = 1, is2
352            xlon  (ii+idif) = xvrai(ii)
353            xprimm(ii+idif) = xxprim(ii)
354           ENDDO
355           DO ii = 1, idif
356            xlon (ii)  = xvrai (ii+is2) - depi
357            xprimm(ii) = xxprim(ii+is2)
358           ENDDO
359         ENDIF
360      ENDIF
361c
362c     .........   Fin  de la reorganisation   ............................
363
364 1600    CONTINUE
365
366
367         xlon  ( iip1)  = xlon(1) + depi
368         xprimm( iip1 ) = xprimm (1 )
369       
370         DO i = 1, iim+1
371         xvrai(i) = xlon(i)*180./pi
372         ENDDO
373
374         IF( ik.EQ.1 )  THEN
375c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
376c          WRITE(6,18)
377c          WRITE(6,68) xvrai
378c          WRITE(6,*) ' XPRIM k ',ik
379c          WRITE(6,566)  xprimm
380
381           DO i = 1,iim +1
382             rlonm025(i) = xlon( i )
383            xprimm025(i) = xprimm(i)
384           ENDDO
385         ELSE IF( ik.EQ.2 )  THEN
386c          WRITE(6,18)
387c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
388c          WRITE(6,68) xvrai
389c          WRITE(6,*) ' XPRIM k ',ik
390c          WRITE(6,566)  xprimm
391
392           DO i = 1,iim + 1
393             rlonv(i) = xlon( i )
394            xprimv(i) = xprimm(i)
395           ENDDO
396
397         ELSE IF( ik.EQ.3)   THEN
398c          WRITE(6,18)
399c          WRITE(6,*)  ' XLON aux pts. U   apres ( en  deg. ) '
400c          WRITE(6,68) xvrai
401c          WRITE(6,*) ' XPRIM ik ',ik
402c          WRITE(6,566)  xprimm
403
404           DO i = 1,iim + 1
405             rlonu(i) = xlon( i )
406            xprimu(i) = xprimm(i)
407           ENDDO
408
409         ELSE IF( ik.EQ.4 )  THEN
410c          WRITE(6,18)
411c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
412c          WRITE(6,68) xvrai
413c          WRITE(6,*) ' XPRIM ik ',ik
414c          WRITE(6,566)  xprimm
415
416           DO i = 1,iim + 1
417             rlonp025(i) = xlon( i )
418            xprimp025(i) = xprimm(i)
419           ENDDO
420
421         ENDIF
422
4235000    CONTINUE
424c
425       WRITE(6,18)
426c
427c    ...........  fin  de la boucle  do 5000      ............
428
429        DO i = 1, iim
430         xlon(i) = rlonv(i+1) - rlonv(i)
431        ENDDO
432        champmin =  1.e12
433        champmax = -1.e12
434        DO i = 1, iim
435         champmin = MIN( champmin, xlon(i) )
436         champmax = MAX( champmax, xlon(i) )
437        ENDDO
438         champmin = champmin * 180./pi
439         champmax = champmax * 180./pi
440
44118     FORMAT(/)
44224     FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3)
44368     FORMAT(1x,7f9.2)
444566    FORMAT(1x,7f9.4)
445
446       RETURN
447       END
Note: See TracBrowser for help on using the repository browser.