/[lmdze]/trunk/dyn3d/fluxstokenc.f90
ViewVC logotype

Diff of /trunk/dyn3d/fluxstokenc.f90

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

trunk/libf/dyn3d/fluxstokenc.f revision 27 by guez, Thu Mar 25 14:29:07 2010 UTC trunk/libf/dyn3d/fluxstokenc.f90 revision 28 by guez, Fri Mar 26 18:33:04 2010 UTC
# Line 1  Line 1 
1        SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,  SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,time_step,itau)
      . time_step,itau )  
2    
3         USE IOIPSL    !     Auteur :  F. Hourdin
 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(  
      .  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.  
   
       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)  
           
         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)  
           
 C  
4    
5        ENDIF ! if iadvtr.EQ.istdyn    USE ioipsl
6      USE dimens_m
7      USE paramet_m
8      USE comconst
9      USE comvert
10      USE comgeom
11      USE temps
12      USE tracstoke
13    
14      IMPLICIT NONE
15    
16      REAL, intent(in):: time_step
17      real t_wrt, t_ops
18      REAL pbaru(ip1jmp1,llm), pbarv(ip1jm,llm)
19      REAL masse(ip1jmp1,llm), teta(ip1jmp1,llm), phi(ip1jmp1,llm)
20      REAL phis(ip1jmp1)
21    
22      REAL pbaruc(ip1jmp1,llm), pbarvc(ip1jm,llm)
23      REAL massem(ip1jmp1,llm), tetac(ip1jmp1,llm), phic(ip1jmp1,llm)
24    
25      REAL pbarug(ip1jmp1,llm), pbarvg(iip1,jjm,llm), wg(ip1jmp1,llm)
26    
27      REAL pbarvst(iip1,jjp1,llm), zistdyn
28      REAL dtcum
29    
30      INTEGER iadvtr, ndex(1)
31      INTEGER nscal
32      REAL tst(1), ist(1), istp(1)
33      INTEGER ij, l, irec, i, j
34      INTEGER, INTENT (IN) :: itau
35      INTEGER fluxid, fluxvid, fluxdid
36    
37      SAVE iadvtr, massem, pbaruc, pbarvc, irec
38      SAVE phic, tetac
39      LOGICAL first
40      SAVE first
41      DATA first/ .TRUE./
42      DATA iadvtr/0/
43    
44      !-------------------------------------------------------------
45    
46      IF (first) THEN
47         CALL initfluxsto(time_step,istdyn*time_step,istdyn*time_step,nqmx, &
48              fluxid,fluxvid,fluxdid)
49    
50         ndex(1) = 0
51         CALL histwrite(fluxid,'phis',1,phis)
52         CALL histwrite(fluxid,'aire',1,aire)
53    
54         ndex(1) = 0
55         nscal = 1
56         tst(1) = time_step
57         CALL histwrite(fluxdid,'dtvr',1,tst)
58         ist(1) = istdyn
59         CALL histwrite(fluxdid,'istdyn',1,ist)
60         istp(1) = istphy
61         CALL histwrite(fluxdid,'istphy',1,istp)
62    
63         first = .FALSE.
64      END IF
65    
66    
67      IF (iadvtr==0) THEN
68         CALL initial0(ijp1llm,phic)
69         CALL initial0(ijp1llm,tetac)
70         CALL initial0(ijp1llm,pbaruc)
71         CALL initial0(ijmllm,pbarvc)
72      END IF
73    
74      !   accumulation des flux de masse horizontaux
75      DO l = 1, llm
76         DO ij = 1, ip1jmp1
77            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
78            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
79            phic(ij,l) = phic(ij,l) + phi(ij,l)
80         END DO
81         DO ij = 1, ip1jm
82            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
83         END DO
84      END DO
85    
86      !   selection de la masse instantannee des mailles avant le transport.
87      IF (iadvtr==0) THEN
88         CALL scopy(ip1jmp1*llm,masse,1,massem,1)
89      END IF
90    
91      iadvtr = iadvtr + 1
92    
93    
94      !   Test pour savoir si on advecte a ce pas de temps
95      IF (iadvtr==istdyn) THEN
96         !    normalisation
97         DO l = 1, llm
98            DO ij = 1, ip1jmp1
99               pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
100               tetac(ij,l) = tetac(ij,l)/float(istdyn)
101               phic(ij,l) = phic(ij,l)/float(istdyn)
102            END DO
103            DO ij = 1, ip1jm
104               pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
105            END DO
106         END DO
107    
108         !   traitement des flux de masse avant advection.
109         !     1. calcul de w
110         !     2. groupement des mailles pres du pole.
111    
112         CALL groupe(massem,pbaruc,pbarvc,pbarug,pbarvg,wg)
113    
114         DO l = 1, llm
115            DO j = 1, jjm
116               DO i = 1, iip1
117                  pbarvst(i,j,l) = pbarvg(i,j,l)
118               END DO
119            END DO
120            DO i = 1, iip1
121               pbarvst(i,jjp1,l) = 0.
122            END DO
123         END DO
124    
125         iadvtr = 0
126         PRINT *, 'ITAU auqel on stoke les fluxmasses', itau
127    
128         CALL histwrite(fluxid,'masse',itau,massem)
129         CALL histwrite(fluxid,'pbaru',itau,pbarug)
130         CALL histwrite(fluxvid,'pbarv',itau,pbarvg)
131         CALL histwrite(fluxid,'w',itau,wg)
132         CALL histwrite(fluxid,'teta',itau,tetac)
133         CALL histwrite(fluxid,'phi',itau,phic)
134      END IF ! if iadvtr.EQ.istdyn                                      
135    
136        RETURN  END SUBROUTINE fluxstokenc
       END  
Legend:
Removed from v.27  
changed lines
  Added in v.28
  ViewVC Help
Powered by ViewVC 1.1.21