Sources/dyn3d/fluxstokenc.f

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

  !     Auteur :  F. Hourdin

  USE ioipsl
  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	SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,time_step,itau)
2
3	! Auteur : F. Hourdin
4
5	USE ioipsl
6	USE dimens_m
7	USE paramet_m
8	USE comconst
9	USE comvert
10	USE comgeom
11	USE temps
12	USE tracstoke
13
14	IMPLICIT NONE
15
16	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
22	REAL pbaruc(ip1jmp1,llm), pbarvc(ip1jm,llm)
23	REAL massem(ip1jmp1,llm), tetac(ip1jmp1,llm), phic(ip1jmp1,llm)
24
25	REAL pbarug(ip1jmp1,llm), pbarvg(iip1,jjm,llm), wg(ip1jmp1,llm)
26
27	REAL pbarvst(iip1,jjp1,llm), zistdyn
28	REAL dtcum
29
30	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
37	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
44	!-------------------------------------------------------------
45
46	IF (first) THEN
47	CALL initfluxsto(time_step,istdyntime_step,istdyntime_step,nqmx, &
48	fluxid,fluxvid,fluxdid)
49
50	ndex(1) = 0
51	CALL histwrite(fluxid,'phis',1,phis)
52	CALL histwrite(fluxid,'aire',1,aire)
53
54	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
63	first = .FALSE.
64	END IF
65
66
67	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
74	! 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
86	! 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
91	iadvtr = iadvtr + 1
92
93
94	! 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
108	! 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