/[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.f revision 3 by guez, Wed Feb 27 13:16:39 2008 UTC trunk/dyn3d/fluxstokenc.f revision 82 by guez, Wed Mar 5 14:57:53 2014 UTC
# Line 1  Line 1 
1        SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,  module fluxstokenc_m
      . time_step,itau )  
2    
3         USE IOIPSL    IMPLICIT NONE
 c  
 c     Auteur :  F. Hourdin  
 c  
 c  
 ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...  
 c  
       use dimens_m  
       use paramet_m  
       use comconst  
       use comvert  
       use comgeom  
       use temps  
       use tracstoke  
       IMPLICIT NONE  
 c  
   
       REAL time_step,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( 'fluxstoke',  
      .  time_step,istdyn* time_step,istdyn* time_step,  
      . nqmx, fluxid,fluxvid,fluxdid)  
           
         ndex(1) = 0  
         call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)  
         call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)  
           
         ndex(1) = 0  
         nscal = 1  
         tst(1) = time_step  
         call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)  
         ist(1)=istdyn  
         call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)  
         istp(1)= istphy  
         call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)  
           
         first = .false.  
   
       endif  
   
   
       IF(iadvtr.EQ.0) THEN  
          CALL initial0(ijp1llm,phic)  
          CALL initial0(ijp1llm,tetac)  
          CALL initial0(ijp1llm,pbaruc)  
          CALL initial0(ijmllm,pbarvc)  
       ENDIF  
   
 c   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)  
          ENDDO  
          DO ij = 1,ip1jm  
             pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)  
          ENDDO  
       ENDDO  
   
 c   selection de la masse instantannee des mailles avant le transport.  
       IF(iadvtr.EQ.0) THEN  
          CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)  
       ENDIF  
   
       iadvtr   = iadvtr+1  
   
   
 c   Test pour savoir si on advecte a ce pas de temps  
       IF ( iadvtr.EQ.istdyn ) THEN  
 c    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)  
          ENDDO  
          DO ij = 1,ip1jm  
             pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)  
          ENDDO  
       ENDDO  
   
 c   traitement des flux de masse avant advection.  
 c     1. calcul de w  
 c     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)  
               enddo  
            enddo  
            do i=1,iip1  
               pbarvst(i,jjp1,l)=0.  
            enddo  
         enddo  
   
          iadvtr=0  
         Print*,'ITAU auqel on stoke les fluxmasses',itau  
           
         call histwrite(fluxid, 'masse', itau, massem,  
      .               iip1*jjp1*llm, ndex)  
           
         call histwrite(fluxid, 'pbaru', itau, pbarug,  
      .               iip1*jjp1*llm, ndex)  
           
         call histwrite(fluxvid, 'pbarv', itau, pbarvg,  
      .               iip1*jjm*llm, ndex)  
           
         call histwrite(fluxid, 'w' ,itau, wg,  
      .             iip1*jjp1*llm, ndex)  
           
         call histwrite(fluxid, 'teta' ,itau, tetac,  
      .             iip1*jjp1*llm, ndex)  
           
         call histwrite(fluxid, 'phi' ,itau, phic,  
      .             iip1*jjp1*llm, ndex)  
           
 C  
4    
5        ENDIF ! if iadvtr.EQ.istdyn  contains
6    
7        RETURN    SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, time_step, itau)
8        END  
9        ! Author: F. Hourdin
10    
11        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    
17        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    
25        ! Variables local to the procedure:
26    
27        REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
28        REAL, SAVE:: massem(ip1jmp1, llm)
29        real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
30    
31        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    
37        !-------------------------------------------------------------
38    
39        IF (itau == 0) THEN
40           CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_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    
51           CALL initial0(ijp1llm, phic)
52           CALL initial0(ijp1llm, tetac)
53           CALL initial0(ijp1llm, pbaruc)
54           CALL initial0(ijmllm, pbarvc)
55        END IF
56    
57        !   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    
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    
74        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    
88           !   traitement des flux de masse avant advection.
89           !     1. calcul de w
90           !     2. groupement des mailles pres du pole.
91    
92           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
Legend:
Removed from v.3  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.21