/[lmdze]/trunk/Sources/dyn3d/fluxstokenc.f
ViewVC logotype

Diff of /trunk/Sources/dyn3d/fluxstokenc.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/dyn3d/fluxstokenc.f90 revision 30 by guez, Thu Apr 1 09:07:28 2010 UTC trunk/Sources/dyn3d/fluxstokenc.f revision 190 by guez, Thu Apr 14 15:15:56 2016 UTC
# Line 1  Line 1 
1  SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,time_step,itau)  module fluxstokenc_m
2    
3    !     Auteur :  F. Hourdin    IMPLICIT NONE
4    
5    USE histwrite_m  contains
   USE dimens_m  
   USE paramet_m  
   USE comconst  
   USE comvert  
   USE comgeom  
   USE temps  
   USE tracstoke  
6    
7    IMPLICIT NONE    SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, time_step, itau)
8    
9        ! Author: F. Hourdin
10    
11        USE histwrite_m, ONLY: histwrite
12        use initfluxsto_m, only: initfluxsto
13        USE dimens_m, ONLY: jjm, llm
14        USE paramet_m, ONLY: iip1, ijmllm, ijp1llm, ip1jm, ip1jmp1
15        USE comgeom, ONLY: aire
16        USE tracstoke, ONLY: istdyn, istphy
17    
18        REAL, intent(in):: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
19        REAL, intent(in):: masse(ip1jmp1, llm)
20        real, intent(in):: phi(ip1jmp1, llm)
21        real, intent(in):: teta(ip1jmp1, llm)
22        REAL, intent(in):: phis(ip1jmp1)
23        REAL, intent(in):: time_step
24        INTEGER, INTENT (IN):: itau
25    
26        ! Local:
27    
28        REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
29        REAL, SAVE:: massem(ip1jmp1, llm)
30        real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
31    
32        REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
33        REAL tst(1), ist(1), istp(1)
34        INTEGER ij, l
35        INTEGER, save:: fluxid, fluxvid
36        integer fluxdid
37    
38        !-------------------------------------------------------------
39    
40        IF (itau == 0) THEN
41           CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, &
42                fluxid, fluxvid, fluxdid)
43           CALL histwrite(fluxid, 'phis', 1, phis)
44           CALL histwrite(fluxid, 'aire', 1, aire)
45           tst(1) = time_step
46           CALL histwrite(fluxdid, 'dtvr', 1, tst)
47           ist(1) = istdyn
48           CALL histwrite(fluxdid, 'istdyn', 1, ist)
49           istp(1) = istphy
50           CALL histwrite(fluxdid, 'istphy', 1, istp)
51    
52           CALL initial0(ijp1llm, phic)
53           CALL initial0(ijp1llm, tetac)
54           CALL initial0(ijp1llm, pbaruc)
55           CALL initial0(ijmllm, pbarvc)
56        END IF
57    
58        ! Accumulation des flux de masse horizontaux
59        DO l = 1, llm
60           DO ij = 1, ip1jmp1
61              pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
62              tetac(ij, l) = tetac(ij, l) + teta(ij, l)
63              phic(ij, l) = phic(ij, l) + phi(ij, l)
64           END DO
65           DO ij = 1, ip1jm
66              pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
67           END DO
68        END DO
69    
70        ! S\'election de la masse instantan\'ee des mailles avant le transport.
71        IF (itau == 0) massem = masse
72    
73        IF (mod(itau + 1, istdyn) == 0) THEN
74           ! On advecte \`a ce pas de temps
75           ! normalisation
76           DO l = 1, llm
77              DO ij = 1, ip1jmp1
78                 pbaruc(ij, l) = pbaruc(ij, l)/float(istdyn)
79                 tetac(ij, l) = tetac(ij, l)/float(istdyn)
80                 phic(ij, l) = phic(ij, l)/float(istdyn)
81              END DO
82              DO ij = 1, ip1jm
83                 pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)
84              END DO
85           END DO
86    
87           ! Traitement des flux de masse avant advection.
88           ! 1. Calcul de w
89           ! 2. Groupement des mailles pr\`es du p\^ole.
90    
91           CALL groupe(pbaruc, pbarvc, pbarug, pbarvg, wg)
92    
93           CALL histwrite(fluxid, 'masse', itau, massem)
94           CALL histwrite(fluxid, 'pbaru', itau, pbarug)
95           CALL histwrite(fluxvid, 'pbarv', itau, pbarvg)
96           CALL histwrite(fluxid, 'w', itau, wg)
97           CALL histwrite(fluxid, 'teta', itau, tetac)
98           CALL histwrite(fluxid, 'phi', itau, phic)
99        END IF
100    
101    REAL, intent(in):: time_step    END SUBROUTINE fluxstokenc
   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                                        
102    
103  END SUBROUTINE fluxstokenc  end module fluxstokenc_m
Legend:
Removed from v.30  
changed lines
  Added in v.190
  ViewVC Help
Powered by ViewVC 1.1.21