source: LMDZ6/trunk/libf/dyn3d/fluxstokenc.f90 @ 5403

Last change on this file since 5403 was 5285, checked in by abarral, 7 weeks ago

As discussed internally, remove generic ONLY: ... for new _mod_h modules

  • 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
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.7 KB
RevLine 
[1279]1!
2! $Id: fluxstokenc.f90 5285 2024-10-28 13:33:29Z abarral $
3!
[5246]4SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, &
5        time_step,itau )
6  ! This routine is designed to work with ioipsl
[541]7
[5282]8   USE iniprint_mod_h
9  USE comgeom_mod_h
[5281]10  USE IOIPSL
[5246]11  !
12  ! Auteur :  F. Hourdin
13  !
14  !
15  !cc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
16  !
[5283]17  USE tracstoke_mod_h
[5271]18  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
[5285]19USE paramet_mod_h
[5271]20IMPLICIT NONE
[5246]21  !
[5271]22
[5272]23
[541]24
[5246]25  REAL :: time_step,t_wrt, t_ops
26  REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
27  REAL :: masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
28  REAL :: phis(ip1jmp1)
[541]29
[5246]30  REAL :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
31  REAL :: massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
[541]32
[5246]33  REAL :: pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
[541]34
[5246]35  REAL :: pbarvst(iip1,jjp1,llm),zistdyn
36    real :: dtcum
[541]37
[5246]38  INTEGER :: iadvtr,ndex(1)
39  integer :: nscal
40  real :: tst(1),ist(1),istp(1)
41  INTEGER :: ij,l,irec,i,j,itau
42  INTEGER, SAVE :: fluxid, fluxvid,fluxdid
[541]43
[5246]44  SAVE iadvtr, massem,pbaruc,pbarvc,irec
45  SAVE phic,tetac
46  logical :: first
47  save first
48  data first/.true./
49  DATA iadvtr/0/
[697]50
51
[5246]52  ! AC initialisations
53  pbarug(:,:)   = 0.
54  pbarvg(:,:,:) = 0.
55  wg(:,:)       = 0.
[541]56
57
[5246]58  if(first) then
[541]59
[5246]60    CALL initfluxsto( 'fluxstoke', &
61          time_step,istdyn* time_step,istdyn* time_step, &
62          fluxid,fluxvid,fluxdid)
[541]63
[5246]64    ndex(1) = 0
65    call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
66    call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
[541]67
[5246]68    ndex(1) = 0
69    nscal = 1
70    tst(1) = time_step
71    call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
72    ist(1)=istdyn
73    call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
74    istp(1)= istphy
75    call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
[541]76
[5246]77    first = .false.
[541]78
[5246]79  endif
[541]80
81
[5246]82  IF(iadvtr.EQ.0) THEN
83     phic(:,:)=0
84     tetac(:,:)=0
85     pbaruc(:,:)=0
86     pbarvc(:,:)=0
87  ENDIF
[541]88
[5246]89  !   accumulation des flux de masse horizontaux
90  DO l=1,llm
91     DO ij = 1,ip1jmp1
92        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
93        tetac(ij,l) = tetac(ij,l) + teta(ij,l)
94        phic(ij,l) = phic(ij,l) + phi(ij,l)
95     ENDDO
96     DO ij = 1,ip1jm
97        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
98     ENDDO
99  ENDDO
[541]100
[5246]101  !   selection de la masse instantannee des mailles avant le transport.
102  IF(iadvtr.EQ.0) THEN
103     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
104  ENDIF
[541]105
[5246]106  iadvtr   = iadvtr+1
[541]107
108
[5246]109  !   Test pour savoir si on advecte a ce pas de temps
110  IF ( iadvtr.EQ.istdyn ) THEN
111  !    normalisation
112  DO l=1,llm
113     DO ij = 1,ip1jmp1
114        pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
115        tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
116        phic(ij,l) = phic(ij,l)/REAL(istdyn)
117     ENDDO
118     DO ij = 1,ip1jm
119        pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
120     ENDDO
121  ENDDO
[541]122
[5246]123  !   traitement des flux de masse avant advection.
124  ! 1. calcul de w
125  ! 2. groupement des mailles pres du pole.
126
127    CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
128
129    do l=1,llm
130       do j=1,jjm
131          do i=1,iip1
132             pbarvst(i,j,l)=pbarvg(i,j,l)
133          enddo
134       enddo
135       do i=1,iip1
136          pbarvst(i,jjp1,l)=0.
137       enddo
138    enddo
139
140     iadvtr=0
141    write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
142
143    call histwrite(fluxid, 'masse', itau, massem, &
144          iip1*jjp1*llm, ndex)
145
146    call histwrite(fluxid, 'pbaru', itau, pbarug, &
147          iip1*jjp1*llm, ndex)
148
149    call histwrite(fluxvid, 'pbarv', itau, pbarvg, &
150          iip1*jjm*llm, ndex)
151
152    call histwrite(fluxid, 'w' ,itau, wg, &
153          iip1*jjp1*llm, ndex)
154
155    call histwrite(fluxid, 'teta' ,itau, tetac, &
156          iip1*jjp1*llm, ndex)
157
158    call histwrite(fluxid, 'phi' ,itau, phic, &
159          iip1*jjp1*llm, ndex)
160
161  !
162
163  ENDIF ! if iadvtr.EQ.istdyn
164
[5267]165
166
[5246]167  RETURN
168END SUBROUTINE fluxstokenc
Note: See TracBrowser for help on using the repository browser.