/[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 15 by guez, Fri Aug 1 15:24:12 2008 UTC trunk/libf/dyn3d/fluxstokenc.f90 revision 44 by guez, Wed Apr 13 12:29:18 2011 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    ! Author: 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( 'fluxstoke',  
      .  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 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    
11      IMPLICIT NONE
12    
13      REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
14      REAL masse(ip1jmp1, llm), phi(ip1jmp1, llm)
15      real, intent(in):: teta(ip1jmp1, llm)
16      REAL phis(ip1jmp1)
17      REAL, intent(in):: time_step
18      INTEGER, INTENT (IN) :: itau
19    
20      ! Variables local to the procedure:
21    
22      REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
23      REAL, SAVE:: massem(ip1jmp1, llm)
24      real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
25    
26      REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
27      REAL tst(1), ist(1), istp(1)
28      INTEGER ij, l
29      INTEGER, save:: fluxid, fluxvid
30      integer fluxdid
31    
32      !-------------------------------------------------------------
33    
34      IF (itau == 0) THEN
35         CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, nqmx, &
36              fluxid, fluxvid, fluxdid)
37         CALL histwrite(fluxid, 'phis', 1, phis)
38         CALL histwrite(fluxid, 'aire', 1, aire)
39         tst(1) = time_step
40         CALL histwrite(fluxdid, 'dtvr', 1, tst)
41         ist(1) = istdyn
42         CALL histwrite(fluxdid, 'istdyn', 1, ist)
43         istp(1) = istphy
44         CALL histwrite(fluxdid, 'istphy', 1, istp)
45    
46         CALL initial0(ijp1llm, phic)
47         CALL initial0(ijp1llm, tetac)
48         CALL initial0(ijp1llm, pbaruc)
49         CALL initial0(ijmllm, pbarvc)
50      END IF
51    
52      !   accumulation des flux de masse horizontaux
53      DO l = 1, llm
54         DO ij = 1, ip1jmp1
55            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         END DO
59         DO ij = 1, ip1jm
60            pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
61         END DO
62      END DO
63    
64      !   selection de la masse instantannee des mailles avant le transport.
65      IF (itau == 0) THEN
66         CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)
67      END IF
68    
69      IF (mod(itau + 1, istdyn) == 0) THEN
70         ! on advecte a ce pas de temps
71         !    normalisation
72         DO l = 1, llm
73            DO ij = 1, ip1jmp1
74               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            END DO
78            DO ij = 1, ip1jm
79               pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)
80            END DO
81         END DO
82    
83         !   traitement des flux de masse avant advection.
84         !     1. calcul de w
85         !     2. groupement des mailles pres du pole.
86    
87         CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
88    
89         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    
97        RETURN  END SUBROUTINE fluxstokenc
       END  
Legend:
Removed from v.15  
changed lines
  Added in v.44
  ViewVC Help
Powered by ViewVC 1.1.21