Sources/dyn3d/fluxstokenc.f

SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,time_step,itau)

  !     Auteur :  F. Hourdin

  USE histwrite_m
  USE dimens_m
  USE paramet_m
  USE comconst
  USE comvert
  USE comgeom
  USE temps
  USE tracstoke

  IMPLICIT NONE

  REAL, intent(in):: time_step
  real t_wrt, t_ops
  REAL pbaru(ip1jmp1,llm), pbarv(ip1jm,llm)
  REAL masse(ip1jmp1,llm), teta(ip1jmp1,llm), phi(ip1jmp1,llm)
  REAL phis(ip1jmp1)

  REAL pbaruc(ip1jmp1,llm), pbarvc(ip1jm,llm)
  REAL massem(ip1jmp1,llm), tetac(ip1jmp1,llm), phic(ip1jmp1,llm)

  REAL pbarug(ip1jmp1,llm), pbarvg(iip1,jjm,llm), wg(ip1jmp1,llm)

  REAL pbarvst(iip1,jjp1,llm), zistdyn
  REAL dtcum

  INTEGER iadvtr, ndex(1)
  INTEGER nscal
  REAL tst(1), ist(1), istp(1)
  INTEGER ij, l, irec, i, j
  INTEGER, INTENT (IN) :: itau
  INTEGER fluxid, fluxvid, fluxdid

  SAVE iadvtr, massem, pbaruc, pbarvc, irec
  SAVE phic, tetac
  LOGICAL first
  SAVE first
  DATA first/ .TRUE./
  DATA iadvtr/0/

  !-------------------------------------------------------------

  IF (first) THEN
     CALL initfluxsto(time_step,istdyn*time_step,istdyn*time_step,nqmx, &
          fluxid,fluxvid,fluxdid)

     ndex(1) = 0
     CALL histwrite(fluxid,'phis',1,phis)
     CALL histwrite(fluxid,'aire',1,aire)

     ndex(1) = 0
     nscal = 1
     tst(1) = time_step
     CALL histwrite(fluxdid,'dtvr',1,tst)
     ist(1) = istdyn
     CALL histwrite(fluxdid,'istdyn',1,ist)
     istp(1) = istphy
     CALL histwrite(fluxdid,'istphy',1,istp)

     first = .FALSE.
  END IF


  IF (iadvtr==0) THEN
     CALL initial0(ijp1llm,phic)
     CALL initial0(ijp1llm,tetac)
     CALL initial0(ijp1llm,pbaruc)
     CALL initial0(ijmllm,pbarvc)
  END IF

  !   accumulation des flux de masse horizontaux
  DO l = 1, llm
     DO ij = 1, ip1jmp1
        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
        tetac(ij,l) = tetac(ij,l) + teta(ij,l)
        phic(ij,l) = phic(ij,l) + phi(ij,l)
     END DO
     DO ij = 1, ip1jm
        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
     END DO
  END DO

  !   selection de la masse instantannee des mailles avant le transport.
  IF (iadvtr==0) THEN
     CALL scopy(ip1jmp1*llm,masse,1,massem,1)
  END IF

  iadvtr = iadvtr + 1


  !   Test pour savoir si on advecte a ce pas de temps
  IF (iadvtr==istdyn) THEN
     !    normalisation
     DO l = 1, llm
        DO ij = 1, ip1jmp1
           pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
           tetac(ij,l) = tetac(ij,l)/float(istdyn)
           phic(ij,l) = phic(ij,l)/float(istdyn)
        END DO
        DO ij = 1, ip1jm
           pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
        END DO
     END DO

     !   traitement des flux de masse avant advection.
     !     1. calcul de w
     !     2. groupement des mailles pres du pole.

     CALL groupe(massem,pbaruc,pbarvc,pbarug,pbarvg,wg)

     DO l = 1, llm
        DO j = 1, jjm
           DO i = 1, iip1
              pbarvst(i,j,l) = pbarvg(i,j,l)
           END DO
        END DO
        DO i = 1, iip1
           pbarvst(i,jjp1,l) = 0.
        END DO
     END DO

     iadvtr = 0
     PRINT *, 'ITAU auqel on stoke les fluxmasses', itau

     CALL histwrite(fluxid,'masse',itau,massem)
     CALL histwrite(fluxid,'pbaru',itau,pbarug)
     CALL histwrite(fluxvid,'pbarv',itau,pbarvg)
     CALL histwrite(fluxid,'w',itau,wg)
     CALL histwrite(fluxid,'teta',itau,tetac)
     CALL histwrite(fluxid,'phi',itau,phic)
  END IF ! if iadvtr.EQ.istdyn                                       

END SUBROUTINE fluxstokenc
1	guez	28	SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,time_step,itau)
2	guez	3
3	guez	28	! Auteur : F. Hourdin
4	guez	3
5	guez	30	USE histwrite_m
6	guez	28	USE dimens_m
7			USE paramet_m
8			USE comconst
9			USE comvert
10			USE comgeom
11			USE temps
12			USE tracstoke
13	guez	3
14	guez	28	IMPLICIT NONE
15	guez	3
16	guez	28	REAL, intent(in):: time_step
17			real t_wrt, t_ops
18			REAL pbaru(ip1jmp1,llm), pbarv(ip1jm,llm)
19			REAL masse(ip1jmp1,llm), teta(ip1jmp1,llm), phi(ip1jmp1,llm)
20			REAL phis(ip1jmp1)
21	guez	3
22	guez	28	REAL pbaruc(ip1jmp1,llm), pbarvc(ip1jm,llm)
23			REAL massem(ip1jmp1,llm), tetac(ip1jmp1,llm), phic(ip1jmp1,llm)
24	guez	3
25	guez	28	REAL pbarug(ip1jmp1,llm), pbarvg(iip1,jjm,llm), wg(ip1jmp1,llm)
26	guez	3
27	guez	28	REAL pbarvst(iip1,jjp1,llm), zistdyn
28			REAL dtcum
29	guez	3
30	guez	28	INTEGER iadvtr, ndex(1)
31			INTEGER nscal
32			REAL tst(1), ist(1), istp(1)
33			INTEGER ij, l, irec, i, j
34			INTEGER, INTENT (IN) :: itau
35			INTEGER fluxid, fluxvid, fluxdid
36	guez	3
37	guez	28	SAVE iadvtr, massem, pbaruc, pbarvc, irec
38			SAVE phic, tetac
39			LOGICAL first
40			SAVE first
41			DATA first/ .TRUE./
42			DATA iadvtr/0/
43	guez	3
44	guez	28	!-------------------------------------------------------------
45	guez	3
46	guez	28	IF (first) THEN
47			CALL initfluxsto(time_step,istdyntime_step,istdyntime_step,nqmx, &
48			fluxid,fluxvid,fluxdid)
49	guez	3
50	guez	28	ndex(1) = 0
51			CALL histwrite(fluxid,'phis',1,phis)
52			CALL histwrite(fluxid,'aire',1,aire)
53	guez	3
54	guez	28	ndex(1) = 0
55			nscal = 1
56			tst(1) = time_step
57			CALL histwrite(fluxdid,'dtvr',1,tst)
58			ist(1) = istdyn
59			CALL histwrite(fluxdid,'istdyn',1,ist)
60			istp(1) = istphy
61			CALL histwrite(fluxdid,'istphy',1,istp)
62	guez	3
63	guez	28	first = .FALSE.
64			END IF
65	guez	3
66
67	guez	28	IF (iadvtr==0) THEN
68			CALL initial0(ijp1llm,phic)
69			CALL initial0(ijp1llm,tetac)
70			CALL initial0(ijp1llm,pbaruc)
71			CALL initial0(ijmllm,pbarvc)
72			END IF
73	guez	3
74	guez	28	! accumulation des flux de masse horizontaux
75			DO l = 1, llm
76			DO ij = 1, ip1jmp1
77			pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
78			tetac(ij,l) = tetac(ij,l) + teta(ij,l)
79			phic(ij,l) = phic(ij,l) + phi(ij,l)
80			END DO
81			DO ij = 1, ip1jm
82			pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
83			END DO
84			END DO
85	guez	3
86	guez	28	! selection de la masse instantannee des mailles avant le transport.
87			IF (iadvtr==0) THEN
88			CALL scopy(ip1jmp1*llm,masse,1,massem,1)
89			END IF
90	guez	3
91	guez	28	iadvtr = iadvtr + 1
92	guez	3
93
94	guez	28	! Test pour savoir si on advecte a ce pas de temps
95			IF (iadvtr==istdyn) THEN
96			! normalisation
97			DO l = 1, llm
98			DO ij = 1, ip1jmp1
99			pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
100			tetac(ij,l) = tetac(ij,l)/float(istdyn)
101			phic(ij,l) = phic(ij,l)/float(istdyn)
102			END DO
103			DO ij = 1, ip1jm
104			pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
105			END DO
106			END DO
107	guez	3
108	guez	28	! traitement des flux de masse avant advection.
109			! 1. calcul de w
110			! 2. groupement des mailles pres du pole.
111
112			CALL groupe(massem,pbaruc,pbarvc,pbarug,pbarvg,wg)
113
114			DO l = 1, llm
115			DO j = 1, jjm
116			DO i = 1, iip1
117			pbarvst(i,j,l) = pbarvg(i,j,l)
118			END DO
119			END DO
120			DO i = 1, iip1
121			pbarvst(i,jjp1,l) = 0.
122			END DO
123			END DO
124
125			iadvtr = 0
126			PRINT *, 'ITAU auqel on stoke les fluxmasses', itau
127
128			CALL histwrite(fluxid,'masse',itau,massem)
129			CALL histwrite(fluxid,'pbaru',itau,pbarug)
130			CALL histwrite(fluxvid,'pbarv',itau,pbarvg)
131			CALL histwrite(fluxid,'w',itau,wg)
132			CALL histwrite(fluxid,'teta',itau,tetac)
133			CALL histwrite(fluxid,'phi',itau,phic)
134			END IF ! if iadvtr.EQ.istdyn
135
136			END SUBROUTINE fluxstokenc