Sources/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), phi(ip1jmp1, llm)
  real, intent(in):: teta(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)
  REAL tst(1), ist(1), istp(1)
  INTEGER ij, l
  INTEGER, save:: fluxid, fluxvid
  integer fluxdid

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

  IF (itau == 0) 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)

     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

  IF (mod(itau + 1, istdyn) == 0) THEN
     ! on advecte a ce pas de temps
     !    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)

     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	guez	44	REAL masse(ip1jmp1, llm), phi(ip1jmp1, llm)
15			real, intent(in):: teta(ip1jmp1, llm)
16	guez	31	REAL phis(ip1jmp1)
17	guez	28	REAL, intent(in):: time_step
18	guez	31	INTEGER, INTENT (IN) :: itau
19	guez	3
20	guez	31	! Variables local to the procedure:
21	guez	3
22	guez	31	REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
23			REAL, SAVE:: massem(ip1jmp1, llm)
24			real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
25	guez	3
26	guez	31	REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
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	guez	3
32	guez	28	!-------------------------------------------------------------
33	guez	3
34	guez	32	IF (itau == 0) THEN
35	guez	31	CALL initfluxsto(time_step, istdyntime_step, istdyntime_step, nqmx, &
36			fluxid, fluxvid, fluxdid)
37			CALL histwrite(fluxid, 'phis', 1, phis)
38			CALL histwrite(fluxid, 'aire', 1, aire)
39	guez	28	tst(1) = time_step
40	guez	31	CALL histwrite(fluxdid, 'dtvr', 1, tst)
41	guez	28	ist(1) = istdyn
42	guez	31	CALL histwrite(fluxdid, 'istdyn', 1, ist)
43	guez	28	istp(1) = istphy
44	guez	31	CALL histwrite(fluxdid, 'istphy', 1, istp)
45	guez	3
46	guez	31	CALL initial0(ijp1llm, phic)
47			CALL initial0(ijp1llm, tetac)
48			CALL initial0(ijp1llm, pbaruc)
49			CALL initial0(ijmllm, pbarvc)
50	guez	28	END IF
51	guez	3
52	guez	28	! accumulation des flux de masse horizontaux
53			DO l = 1, llm
54			DO ij = 1, ip1jmp1
55	guez	31	pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
56			tetac(ij, l) = tetac(ij, l) + teta(ij, l)
57			phic(ij, l) = phic(ij, l) + phi(ij, l)
58	guez	28	END DO
59			DO ij = 1, ip1jm
60	guez	31	pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
61	guez	28	END DO
62			END DO
63	guez	3
64	guez	28	! selection de la masse instantannee des mailles avant le transport.
65	guez	31	IF (itau == 0) THEN
66			CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)
67	guez	28	END IF
68	guez	3
69	guez	32	IF (mod(itau + 1, istdyn) == 0) THEN
70			! on advecte a ce pas de temps
71	guez	28	! normalisation
72			DO l = 1, llm
73			DO ij = 1, ip1jmp1
74	guez	31	pbaruc(ij, l) = pbaruc(ij, l)/float(istdyn)
75			tetac(ij, l) = tetac(ij, l)/float(istdyn)
76			phic(ij, l) = phic(ij, l)/float(istdyn)
77	guez	28	END DO
78			DO ij = 1, ip1jm
79	guez	31	pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)
80	guez	28	END DO
81			END DO
82	guez	3
83	guez	28	! traitement des flux de masse avant advection.
84			! 1. calcul de w
85			! 2. groupement des mailles pres du pole.
86
87	guez	31	CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
88	guez	28
89	guez	31	CALL histwrite(fluxid, 'masse', itau, massem)
90			CALL histwrite(fluxid, 'pbaru', itau, pbarug)
91			CALL histwrite(fluxvid, 'pbarv', itau, pbarvg)
92			CALL histwrite(fluxid, 'w', itau, wg)
93			CALL histwrite(fluxid, 'teta', itau, tetac)
94			CALL histwrite(fluxid, 'phi', itau, phic)
95			END IF
96	guez	28
97			END SUBROUTINE fluxstokenc