trunk/dyn3d/fluxstokenc.f

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

  ! Author: F. Hourdin

  USE histwrite_m, ONLY : histwrite
  USE dimens_m, ONLY : jjm, llm, nqmx
  USE paramet_m, ONLY : iip1, ijmllm, ijp1llm, ip1jm, ip1jmp1, jjp1
  USE comgeom, ONLY : aire
  USE tracstoke, ONLY : istdyn, istphy

  IMPLICIT NONE

  REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
  REAL masse(ip1jmp1, llm), teta(ip1jmp1, llm), phi(ip1jmp1, llm)
  REAL phis(ip1jmp1)
  REAL, intent(in):: time_step
  INTEGER, INTENT (IN) :: itau

  ! Variables local to the procedure:

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

  REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
  INTEGER:: iadvtr = 0
  REAL tst(1), ist(1), istp(1)
  INTEGER ij, l
  INTEGER, save:: fluxid, fluxvid
  integer fluxdid
  LOGICAL:: first = .TRUE.

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

  IF (first) THEN
     CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, nqmx, &
          fluxid, fluxvid, fluxdid)
     CALL histwrite(fluxid, 'phis', 1, phis)
     CALL histwrite(fluxid, 'aire', 1, aire)
     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 (itau == 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 (itau == 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)
     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                                 

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