Changeset 5246 for LMDZ6/trunk/libf/dyn3d/fluxstokenc.F90
- Timestamp:
- Oct 21, 2024, 2:58:45 PM (23 hours ago)
- File:
-
- 1 moved
-
LMDZ6/trunk/libf/dyn3d/fluxstokenc.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3d/fluxstokenc.F) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/dyn3d/fluxstokenc.F90
r5245 r5246 2 2 ! $Id$ 3 3 ! 4 SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, 5 .time_step,itau )4 SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, & 5 time_step,itau ) 6 6 #ifdef CPP_IOIPSL 7 ! This routine is designed to work with ioipsl7 ! This routine is designed to work with ioipsl 8 8 9 10 c 11 cAuteur : F. Hourdin12 c 13 c 14 ccc .. Modif. P. Le Van ( 20/12/97 ) ...15 c 16 17 c 18 19 20 21 22 9 USE IOIPSL 10 ! 11 ! Auteur : F. Hourdin 12 ! 13 ! 14 !cc .. Modif. P. Le Van ( 20/12/97 ) ... 15 ! 16 IMPLICIT NONE 17 ! 18 include "dimensions.h" 19 include "paramet.h" 20 include "comgeom.h" 21 include "tracstoke.h" 22 include "iniprint.h" 23 23 24 REALtime_step,t_wrt, t_ops25 REALpbaru(ip1jmp1,llm),pbarv(ip1jm,llm)26 REALmasse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)27 REALphis(ip1jmp1)24 REAL :: time_step,t_wrt, t_ops 25 REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) 26 REAL :: masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm) 27 REAL :: phis(ip1jmp1) 28 28 29 REALpbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)30 REALmassem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)29 REAL :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) 30 REAL :: massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm) 31 31 32 REALpbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)32 REAL :: pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm) 33 33 34 REALpbarvst(iip1,jjp1,llm),zistdyn35 realdtcum34 REAL :: pbarvst(iip1,jjp1,llm),zistdyn 35 real :: dtcum 36 36 37 INTEGER iadvtr,ndex(1)38 integernscal39 realtst(1),ist(1),istp(1)40 INTEGERij,l,irec,i,j,itau41 42 43 44 45 logicalfirst46 47 48 37 INTEGER :: iadvtr,ndex(1) 38 integer :: nscal 39 real :: tst(1),ist(1),istp(1) 40 INTEGER :: ij,l,irec,i,j,itau 41 INTEGER, SAVE :: fluxid, fluxvid,fluxdid 42 43 SAVE iadvtr, massem,pbaruc,pbarvc,irec 44 SAVE phic,tetac 45 logical :: first 46 save first 47 data first/.true./ 48 DATA iadvtr/0/ 49 49 50 50 51 c AC initialisations 52 pbarug(:,:) = 0. 53 pbarvg(:,:,:) = 0. 54 wg(:,:) = 0. 55 56 57 if(first) then 58 59 CALL initfluxsto( 'fluxstoke', 60 . time_step,istdyn* time_step,istdyn* time_step, 61 . fluxid,fluxvid,fluxdid) 62 63 ndex(1) = 0 64 call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex) 65 call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex) 66 67 ndex(1) = 0 68 nscal = 1 69 tst(1) = time_step 70 call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex) 71 ist(1)=istdyn 72 call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex) 73 istp(1)= istphy 74 call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex) 75 76 first = .false. 77 78 endif 51 ! AC initialisations 52 pbarug(:,:) = 0. 53 pbarvg(:,:,:) = 0. 54 wg(:,:) = 0. 79 55 80 56 81 IF(iadvtr.EQ.0) THEN 82 phic(:,:)=0 83 tetac(:,:)=0 84 pbaruc(:,:)=0 85 pbarvc(:,:)=0 86 ENDIF 57 if(first) then 87 58 88 c accumulation des flux de masse horizontaux 89 DO l=1,llm 90 DO ij = 1,ip1jmp1 91 pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) 92 tetac(ij,l) = tetac(ij,l) + teta(ij,l) 93 phic(ij,l) = phic(ij,l) + phi(ij,l) 94 ENDDO 95 DO ij = 1,ip1jm 96 pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) 97 ENDDO 98 ENDDO 59 CALL initfluxsto( 'fluxstoke', & 60 time_step,istdyn* time_step,istdyn* time_step, & 61 fluxid,fluxvid,fluxdid) 99 62 100 c selection de la masse instantannee des mailles avant le transport. 101 IF(iadvtr.EQ.0) THEN 102 CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) 103 ENDIF 63 ndex(1) = 0 64 call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex) 65 call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex) 104 66 105 iadvtr = iadvtr+1 67 ndex(1) = 0 68 nscal = 1 69 tst(1) = time_step 70 call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex) 71 ist(1)=istdyn 72 call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex) 73 istp(1)= istphy 74 call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex) 75 76 first = .false. 77 78 endif 106 79 107 80 108 c Test pour savoir si on advecte a ce pas de temps 109 IF ( iadvtr.EQ.istdyn ) THEN 110 c normalisation 111 DO l=1,llm 112 DO ij = 1,ip1jmp1 113 pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn) 114 tetac(ij,l) = tetac(ij,l)/REAL(istdyn) 115 phic(ij,l) = phic(ij,l)/REAL(istdyn) 116 ENDDO 117 DO ij = 1,ip1jm 118 pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn) 119 ENDDO 120 ENDDO 81 IF(iadvtr.EQ.0) THEN 82 phic(:,:)=0 83 tetac(:,:)=0 84 pbaruc(:,:)=0 85 pbarvc(:,:)=0 86 ENDIF 121 87 122 c traitement des flux de masse avant advection. 123 c 1. calcul de w 124 c 2. groupement des mailles pres du pole. 88 ! accumulation des flux de masse horizontaux 89 DO l=1,llm 90 DO ij = 1,ip1jmp1 91 pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) 92 tetac(ij,l) = tetac(ij,l) + teta(ij,l) 93 phic(ij,l) = phic(ij,l) + phi(ij,l) 94 ENDDO 95 DO ij = 1,ip1jm 96 pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) 97 ENDDO 98 ENDDO 125 99 126 CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) 100 ! selection de la masse instantannee des mailles avant le transport. 101 IF(iadvtr.EQ.0) THEN 102 CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) 103 ENDIF 127 104 128 do l=1,llm 129 do j=1,jjm 130 do i=1,iip1 131 pbarvst(i,j,l)=pbarvg(i,j,l) 132 enddo 133 enddo 134 do i=1,iip1 135 pbarvst(i,jjp1,l)=0. 136 enddo 137 enddo 105 iadvtr = iadvtr+1 138 106 139 iadvtr=0140 write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau141 142 call histwrite(fluxid, 'masse', itau, massem,143 . iip1*jjp1*llm, ndex)144 145 call histwrite(fluxid, 'pbaru', itau, pbarug,146 . iip1*jjp1*llm, ndex)147 148 call histwrite(fluxvid, 'pbarv', itau, pbarvg,149 . iip1*jjm*llm, ndex)150 151 call histwrite(fluxid, 'w' ,itau, wg,152 . iip1*jjp1*llm, ndex)153 154 call histwrite(fluxid, 'teta' ,itau, tetac,155 . iip1*jjp1*llm, ndex)156 157 call histwrite(fluxid, 'phi' ,itau, phic,158 . iip1*jjp1*llm, ndex)159 160 C161 107 162 ENDIF ! if iadvtr.EQ.istdyn 108 ! Test pour savoir si on advecte a ce pas de temps 109 IF ( iadvtr.EQ.istdyn ) THEN 110 ! normalisation 111 DO l=1,llm 112 DO ij = 1,ip1jmp1 113 pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn) 114 tetac(ij,l) = tetac(ij,l)/REAL(istdyn) 115 phic(ij,l) = phic(ij,l)/REAL(istdyn) 116 ENDDO 117 DO ij = 1,ip1jm 118 pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn) 119 ENDDO 120 ENDDO 121 122 ! traitement des flux de masse avant advection. 123 ! 1. calcul de w 124 ! 2. groupement des mailles pres du pole. 125 126 CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) 127 128 do l=1,llm 129 do j=1,jjm 130 do i=1,iip1 131 pbarvst(i,j,l)=pbarvg(i,j,l) 132 enddo 133 enddo 134 do i=1,iip1 135 pbarvst(i,jjp1,l)=0. 136 enddo 137 enddo 138 139 iadvtr=0 140 write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau 141 142 call histwrite(fluxid, 'masse', itau, massem, & 143 iip1*jjp1*llm, ndex) 144 145 call histwrite(fluxid, 'pbaru', itau, pbarug, & 146 iip1*jjp1*llm, ndex) 147 148 call histwrite(fluxvid, 'pbarv', itau, pbarvg, & 149 iip1*jjm*llm, ndex) 150 151 call histwrite(fluxid, 'w' ,itau, wg, & 152 iip1*jjp1*llm, ndex) 153 154 call histwrite(fluxid, 'teta' ,itau, tetac, & 155 iip1*jjp1*llm, ndex) 156 157 call histwrite(fluxid, 'phi' ,itau, phic, & 158 iip1*jjp1*llm, ndex) 159 160 ! 161 162 ENDIF ! if iadvtr.EQ.istdyn 163 163 164 164 #else 165 write(lunout,*)166 &'fluxstokenc: Needs IOIPSL to function'165 write(lunout,*) & 166 'fluxstokenc: Needs IOIPSL to function' 167 167 #endif 168 ! of #ifdef CPP_IOIPSL169 170 END 168 ! of #ifdef CPP_IOIPSL 169 RETURN 170 END SUBROUTINE fluxstokenc
Note: See TracChangeset
for help on using the changeset viewer.
