source: LMDZ6/trunk/libf/dyn3dmem/iniacademic_loc.F90 @ 5267

Last change on this file since 5267 was 5267, checked in by abarral, 2 days ago

Remove CPP_IOIPSL cpp keys uses
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 13.3 KB
Line 
1!
2! $Id: iniacademic.F90 1625 2012-05-09 13:14:48Z lguez $
3!
4SUBROUTINE iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
5
6  USE filtreg_mod, ONLY: inifilr
7  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, isoName, addPhase
8  USE control_mod, ONLY: day_step,planet_type
9  use exner_hyb_m, only: exner_hyb
10  use exner_milieu_m, only: exner_milieu
11  USE parallel_lmdz, ONLY: ijb_u, ije_u, ijb_v, ije_v
12  USE IOIPSL, ONLY: getin
13
14  USE Write_Field
15  USE comconst_mod, ONLY: cpp, kappa, g, daysec, dtvr, pi, im, jm
16  USE logic_mod, ONLY: iflag_phys, read_start
17  USE comvert_mod, ONLY: ap, bp, preff, pa, presnivs, pressure_exner
18  USE temps_mod, ONLY: annee_ref, day_ini, day_ref
19  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
20  use netcdf, only : NF90_NOWRITE,NF90_OPEN,NF90_NOERR,NF90_INQ_VARID
21  use netcdf, only : NF90_CLOSE, NF90_GET_VAR
22  USE iso_params_mod   ! tnat_* and alpha_ideal_*
23
24
25  !   Author:    Frederic Hourdin      original: 15/01/93
26  ! The forcing defined here is from Held and Suarez, 1994, Bulletin
27  ! of the American Meteorological Society, 75, 1825.
28
29  IMPLICIT NONE
30
31  !   Declararations:
32  !   ---------------
33
34  include "dimensions.h"
35  include "paramet.h"
36  include "comgeom.h"
37  include "academic.h"
38  include "iniprint.h"
39
40  !   Arguments:
41  !   ----------
42
43  REAL,INTENT(OUT) :: time_0
44
45  !   fields
46  REAL,INTENT(OUT) :: vcov(ijb_v:ije_v,llm) ! meridional covariant wind
47  REAL,INTENT(OUT) :: ucov(ijb_u:ije_u,llm) ! zonal covariant wind
48  REAL,INTENT(OUT) :: teta(ijb_u:ije_u,llm) ! potential temperature (K)
49  REAL,INTENT(OUT) :: q(ijb_u:ije_u,llm,nqtot) ! advected tracers (.../kg_of_air)
50  REAL,INTENT(OUT) :: ps(ijb_u:ije_u) ! surface pressure (Pa)
51  REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass in grid cell (kg)
52  REAL,INTENT(OUT) :: phis(ijb_u:ije_u) ! surface geopotential
53
54  !   Local:
55  !   ------
56
57  REAL,ALLOCATABLE :: vcov_glo(:,:),ucov_glo(:,:),teta_glo(:,:)
58  REAL,ALLOCATABLE :: q_glo(:,:),masse_glo(:,:),ps_glo(:)
59  REAL,ALLOCATABLE :: phis_glo(:)
60  REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
61  REAL pks(ip1jmp1)                      ! exner au  sol
62  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
63  REAL phi(ip1jmp1,llm)                  ! geopotentiel
64  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
65  real tetastrat ! potential temperature in the stratosphere, in K
66  real tetajl(jjp1,llm)
67  INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent
68
69  integer :: nid_relief,varid,ierr
70  real, dimension(iip1,jjp1) :: relief
71
72
73  REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T
74  REAL k_f,k_c_a,k_c_s         ! Constantes de rappel
75  LOGICAL ok_geost             ! Initialisation vent geost. ou nul
76  LOGICAL ok_pv                ! Polar Vortex
77  REAL phi_pv,dphi_pv,gam_pv,tetanoise   ! Constantes pour polar vortex
78
79  real zz,ran1
80  integer idum
81
82  REAL zdtvr, tnat, alpha_ideal
83  LOGICAL :: ltnat1
84 
85  character(len=*),parameter :: modname="iniacademic"
86  character(len=80) :: abort_message
87
88  ! Sanity check: verify that options selected by user are not incompatible
89  if ((iflag_phys==1).and. .not. read_start) then
90    write(lunout,*) trim(modname)," error: if read_start is set to ", &
91    " false then iflag_phys should not be 1"
92    write(lunout,*) "You most likely want an aquaplanet initialisation", &
93    " (iflag_phys >= 100)"
94    call abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
95  endif
96 
97  !-----------------------------------------------------------------------
98  ! 1. Initializations for Earth-like case
99  ! --------------------------------------
100  !
101  ! initialize planet radius, rotation rate,...
102  call conf_planete
103
104  time_0=0.
105  day_ref=1
106  ! annee_ref=0
107
108  im         = iim
109  jm         = jjm
110  day_ini    = 1
111  dtvr    = daysec/REAL(day_step)
112  zdtvr=dtvr
113  etot0      = 0.
114  ptot0      = 0.
115  ztot0      = 0.
116  stot0      = 0.
117  ang0       = 0.
118
119  if (llm == 1) then
120     ! specific initializations for the shallow water case
121     kappa=1
122  endif
123
124  CALL iniconst
125  CALL inigeom
126  CALL inifilr
127
128  ! Initialize pressure and mass field if read_start=.false.
129  IF (.NOT. read_start) THEN
130    ! allocate global fields:
131!    allocate(vcov_glo(ip1jm,llm))
132
133    allocate(ucov_glo(ip1jmp1,llm))
134    allocate(teta_glo(ip1jmp1,llm))
135    allocate(ps_glo(ip1jmp1))
136    allocate(masse_glo(ip1jmp1,llm))
137    allocate(phis_glo(ip1jmp1))
138
139     ! surface pressure
140     ps_glo(:)=preff
141
142     !------------------------------------------------------------------
143     ! Lecture eventuelle d'un fichier de relief interpollee sur la grille
144     ! du modele.
145     ! On suppose que le fichier relief_in.nc est stoké sur une grille
146     ! iim*jjp1
147     ! Facile a créer à partir de la commande
148     ! cdo remapcon,fichier_output_phys.nc Relief.nc relief_in.nc
149     !------------------------------------------------------------------
150
151     relief=0.
152     ierr = NF90_OPEN ('relief_in.nc', NF90_NOWRITE,nid_relief)
153     if (ierr.EQ.NF90_NOERR) THEN
154         ierr=NF90_INQ_VARID(nid_relief,'RELIEF',varid)
155         if (ierr==NF90_NOERR) THEN
156              ierr=NF90_GET_VAR(nid_relief,varid,relief(1:iim,1:jjp1))
157              relief(iip1,:)=relief(1,:)
158         else
159              CALL abort_gcm ('iniacademic','variable RELIEF pas la',1)
160         endif
161     endif
162     ierr = NF90_CLOSE (nid_relief)
163
164
165     !------------------------------------------------------------------
166     ! Initialisation du geopotentiel au sol et de la pression
167     !------------------------------------------------------------------
168
169     print*,'relief=',minval(relief),maxval(relief),'g=',g
170     do j=1,jjp1
171        do i=1,iip1
172           phis_glo((j-1)*iip1+i)=g*relief(i,j)
173        enddo
174     enddo
175     print*,'phis=',minval(phis),maxval(phis),'g=',g
176
177     CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
178     if (pressure_exner) then
179       CALL exner_hyb( ip1jmp1, ps_glo, p, pks, pk )
180     else
181       call exner_milieu(ip1jmp1,ps_glo,p,pks,pk)
182     endif
183     CALL massdair(p,masse_glo)
184  ENDIF
185
186  if (llm == 1) then
187     ! initialize fields for the shallow water case, if required
188     if (.not.read_start) then
189        phis(ijb_u:ije_u)=0.
190        q(ijb_u:ije_u,1:llm,1:nqtot)=0
191        CALL sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
192     endif
193  endif
194
195  academic_case: if (iflag_phys >= 2) then
196     ! initializations
197
198     ! 1. local parameters
199     ! by convention, winter is in the southern hemisphere
200     ! Geostrophic wind or no wind?
201     ok_geost=.TRUE.
202     CALL getin('ok_geost',ok_geost)
203     ! Constants for Newtonian relaxation and friction
204     k_f=1.                !friction
205     CALL getin('k_j',k_f)
206     k_f=1./(daysec*k_f)
207     k_c_s=4.  !cooling surface
208     CALL getin('k_c_s',k_c_s)
209     k_c_s=1./(daysec*k_c_s)
210     k_c_a=40. !cooling free atm
211     CALL getin('k_c_a',k_c_a)
212     k_c_a=1./(daysec*k_c_a)
213     ! Constants for Teta equilibrium profile
214     teta0=315.     ! mean Teta (S.H. 315K)
215     CALL getin('teta0',teta0)
216     ttp=200.       ! Tropopause temperature (S.H. 200K)
217     CALL getin('ttp',ttp)
218     eps=0.         ! Deviation to N-S symmetry(~0-20K)
219     CALL getin('eps',eps)
220     delt_y=60.     ! Merid Temp. Gradient (S.H. 60K)
221     CALL getin('delt_y',delt_y)
222     delt_z=10.     ! Vertical Gradient (S.H. 10K)
223     CALL getin('delt_z',delt_z)
224     ! Polar vortex
225     ok_pv=.false.
226     CALL getin('ok_pv',ok_pv)
227     phi_pv=-50.            ! Latitude of edge of vortex
228     CALL getin('phi_pv',phi_pv)
229     phi_pv=phi_pv*pi/180.
230     dphi_pv=5.             ! Width of the edge
231     CALL getin('dphi_pv',dphi_pv)
232     dphi_pv=dphi_pv*pi/180.
233     gam_pv=4.              ! -dT/dz vortex (in K/km)
234     CALL getin('gam_pv',gam_pv)
235     tetanoise=0.005
236     CALL getin('tetanoise',tetanoise)
237
238     ! 2. Initialize fields towards which to relax
239     ! Friction
240     knewt_g=k_c_a
241     DO l=1,llm
242        zsig=presnivs(l)/preff
243        knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3)
244        kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3)
245     ENDDO
246     DO j=1,jjp1
247        clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4
248     ENDDO
249
250     ! Potential temperature
251     DO l=1,llm
252        zsig=presnivs(l)/preff
253        tetastrat=ttp*zsig**(-kappa)
254        tetapv=tetastrat
255        IF ((ok_pv).AND.(zsig.LT.0.1)) THEN
256           tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g)
257        ENDIF
258        DO j=1,jjp1
259           ! Troposphere
260           ddsin=sin(rlatu(j))
261           tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin &
262                -delt_z*(1.-ddsin*ddsin)*log(zsig)
263           if (planet_type=="giant") then
264             tetajl(j,l)=teta0+(delt_y*                   &
265                ((sin(rlatu(j)*3.14159*eps+0.0001))**2)   &
266                / ((rlatu(j)*3.14159*eps+0.0001)**2))     &
267                -delt_z*log(zsig)
268           endif
269           ! Profil stratospherique isotherme (+vortex)
270           w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2.
271           tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv             
272           tetajl(j,l)=MAX(tetajl(j,l),tetastrat) 
273        ENDDO
274     ENDDO
275
276     !          CALL writefield('theta_eq',tetajl)
277
278     do l=1,llm
279        do j=1,jjp1
280           do i=1,iip1
281              ij=(j-1)*iip1+i
282              tetarappel(ij,l)=tetajl(j,l)
283           enddo
284        enddo
285     enddo
286
287     ! 3. Initialize fields (if necessary)
288     IF (.NOT. read_start) THEN
289        ! bulk initialization of temperature
290        IF (iflag_phys>10000) THEN
291        ! Particular case to impose a constant temperature T0=0.01*iflag_phys
292           teta_glo(:,:)= 0.01*iflag_phys/(pk(:,:)/cpp)
293        ELSE
294           teta_glo(:,:)=tetarappel(:,:)
295        ENDIF
296        ! geopotential
297        CALL geopot(ip1jmp1,teta_glo,pk,pks,phis_glo,phi)
298
299        ! winds
300        if (ok_geost) then
301           call ugeostr(phi,ucov_glo)
302        else
303           ucov_glo(:,:)=0.
304        endif
305        vcov(ijb_v:ije_v,1:llm)=0.
306
307        ! bulk initialization of tracers
308        if (planet_type=="earth") then
309           ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
310           ! Earth: first two tracers will be water
311           do iq=1,nqtot
312              q(ijb_u:ije_u,:,iq)=0.
313              IF(tracers(iq)%name == addPhase('H2O', 'g')) q(ijb_u:ije_u,:,iq)=1.e-10
314              IF(tracers(iq)%name == addPhase('H2O', 'l')) q(ijb_u:ije_u,:,iq)=1.e-15
315
316              ! CRisi: init des isotopes
317              ! distill de Rayleigh très simplifiée
318              iName    = tracers(iq)%iso_iName
319              if (niso <= 0 .OR. iName <= 0) CYCLE
320              iPhase   = tracers(iq)%iso_iPhase
321              iqParent = tracers(iq)%iqParent
322              IF(tracers(iq)%iso_iZone == 0) THEN
323                 IF(ltnat1) THEN
324                    tnat = 1.0
325                    alpha_ideal = 1.0
326                    WRITE(lunout, *) 'In '//TRIM(modname)//': !!!  Beware: alpha_ideal put to 1  !!!'
327                 ELSE
328                    SELECT CASE(isoName(iName))
329                      CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
330                      CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
331                      CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
332                      CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
333                      CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
334                      CASE DEFAULT
335                         CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
336                    END SELECT
337                 END IF
338                 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
339              ELSE !IF(tracers(iq)%iso_iZone == 0) THEN
340                 IF(tracers(iq)%iso_iZone == 1) THEN ! a verifier.
341                    ! correction le 14 mai 2024 pour que tous les traceurs soient de la couleur 1.
342                    ! Sinon, on va avoir des porblèmes de conservation de masse de traceurs.
343                    q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
344                 else !IF(tracers(iq)%iso_iZone == 1) THEN
345                    q(ijb_u:ije_u,:,iq) = 0.0
346                 endif !IF(tracers(iq)%iso_iZone == 1) THEN
347              END IF !IF(tracers(iq)%iso_iZone == 0) THEN
348           enddo
349        else
350           q(ijb_u:ije_u,:,:)=0
351        endif ! of if (planet_type=="earth")
352
353        call check_isotopes(q,ijb_u,ije_u,'iniacademic_loc')
354
355        ! add random perturbation to temperature
356        idum  = -1
357        zz = ran1(idum)
358        idum  = 0
359        do l=1,llm
360           do ij=iip2,ip1jm
361              teta_glo(ij,l)=teta_glo(ij,l)*(1.+tetanoise*ran1(idum))
362           enddo
363        enddo
364
365        ! maintain periodicity in longitude
366        do l=1,llm
367           do ij=1,ip1jmp1,iip1
368              teta_glo(ij+iim,l)=teta_glo(ij,l)
369           enddo
370        enddo
371
372        ! copy data from global array to local array:
373        teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
374        ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
375!        vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
376        masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
377        ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
378        phis(ijb_u:ije_u)=phis_glo(ijb_u:ije_u)
379
380        deallocate(teta_glo)
381        deallocate(ucov_glo)
382!        deallocate(vcov_glo)
383        deallocate(masse_glo)
384        deallocate(ps_glo)
385        deallocate(phis_glo)
386     ENDIF ! of IF (.NOT. read_start)
387  endif academic_case
388
389END SUBROUTINE iniacademic_loc
Note: See TracBrowser for help on using the repository browser.