Sources/dyn3d/fluxstokenc.f

module fluxstokenc_m

  IMPLICIT NONE

contains

  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

    REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
    REAL masse(ip1jmp1, llm)
    real, intent(in):: phi(ip1jmp1, llm)
    real, intent(in):: teta(ip1jmp1, llm)
    REAL, intent(in):: 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

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