*=*=*=*= testdyn.html =*=*=*=*
PROGRAM testdyn IMPLICIT NONE c======================================================================= c c Auteur: P. Le Van/ L.Fairhead/F.Hourdin c ------- c Modif special traceur F.Forget 05/94 c c Objet: c ------ c c GCM LMD nouvelle grille c c======================================================================= c ... modification de l'integration de q ( 26/04/94 ) .... c----------------------------------------------------------------------- c Declarations: c ------------- #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comdissip.h" #include "comvert.h" #include "comgeom.h" #include "logic.h" #include "temps.h" #include "control.h" #include "ener.h" #include "drsdef.h" #include "description.h" INTEGER*4 iday ! jour julien REAL time ! Heure de la journee en fraction d'1 jour REAL zdtvr INTEGER nbetatmoy, nbetatdem,nbetat INTEGER ierr, aslun, cllun c variables dynamiques REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants REAL h(ip1jmp1,llm) ! temperature potentielle REAL q(ip1jmp1,llm,nqmx) ! champs advectes REAL pext(ip1jmp1) ! pression extensive REAL pks(ip1jmp1),pksf(ip1jmp1) ! exner (f pour filtre) REAL phis(ip1jmp1) ! geopotentiel au sol REAL phi(ip1jmp1,llm) ! geopotentiel REAL w(ip1jmp1,llm) ! vitesse verticale c variables dynamiques intermediaire pour le transport REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse c variables dynamiques au pas -1 REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) REAL hm1(ip1jmp1,llm),pextm1(ip1jmp1) c z.x.li REAL qm1(ip1jmp1,llm,nqmx) c tendances dynamiques REAL dv(ip1jm,llm),du(ip1jmp1,llm) REAL dh(ip1jmp1,llm),dq(ip1jmp1,llm,nqmx),dp(ip1jmp1) c tendances de la dissipation REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm) REAL dhdis(ip1jmp1,llm) c tendances physiques REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm) REAL dhfi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1) c rappel Newtonnien REAL teq(ip1jmp1,llm) ! temperature de rappel REAL cterad ! constante de temps c variables pour le fichier histoire REAL dtav ! intervalle de temps elementaire INTEGER iadv(nqmx) ! indice schema de transport pour le traceur iq INTEGER taphistd,taprstar,taphmoy,tapphys INTEGER itau,itaufinp1,iav,ij,l EXTERNAL caldyn, traceur EXTERNAL dissip,geopot,iniconst,inifilr,ecriba EXTERNAL integrd,lectba,SCOPY EXTERNAL iniav,writeav EXTERNAL inigeom EXTERNAL exner,addit REAL time_0 , finvpold(ip1jmp1) LOGICAL startdrs c----------------------------------------------------------------------- c Initialisations: c ---------------- c quelques constantes pour la dissipation tetavel=30000. tetatemp=30000. niterdis=2 lstardis=.false. grireg=.true. startdrs=.true. descript='Test DRS sur testdyn' c----------------------------------------------------------------------- CALL lectba(startdrs,nqmx,vcov,ucov,h,q,pext,phis,time_0) CALL defrun(5) c on recalcule eventuellement le pas de temps IF(MOD(day_step,iperiod).NE.0) sSTOP'Il faut choisir un nb de pas par jour multiple de iperiod' zdtvr = daysec/float(day_step) IF(dtvr.NE.zdtvr) THEN PRINT*,'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr ENDIF c nombre d'etats dans les fichiers demarrage et histoire nbetatdem = nday / iecri nbetatmoy = nday / periodav + 1 dtvr=zdtvr CALL iniconst CALL inigeom IF(grireg) CALL inifilr CALL inidissip(lstardis,niterdis,tetavel,tetatemp) CALL exner(ip1jmp1,pext,aire,pks,pksf) c numero de stockage pour les fichiers de redemarrage: taphistd=10 tapphys=12 taprstar=15 taphmoy=20 c ouverture DRS des fichiers de stockage IF(startdrs) THEN ierr = aslun(taphistd,'histoire.dic', . taphistd+1,'histoire.dat',IDRS_CREATE) ELSE PRINT*,'Ouverture binaire',taphistd OPEN(taphistd,file='histoire',form='unformatted', . status='new',iostat=ierr) ENDIF if (ierr.ne.0) then write(6,*)' Pb d''ouverture du fichier histoire (rdem)' write(6,*)' ierr = ', ierr call exit(1) endif IF(startdrs) THEN ierr = aslun(taprstar,'restart.dic', . taprstar+1,'restart.dat',IDRS_CREATE) ELSE OPEN(taprstar,file='restart',form='unformatted', . status='new',iostat=ierr) ENDIF if (ierr.ne.0) then write(6,*)' Pb d''ouverture du fichier restart' write(6,*)' ierr = ', ierr call exit(1) endif ierr = aslun(taphmoy,'histmoy.dic', . taphmoy+1,'histmoy.dat',IDRS_CREATE) if (ierr.ne.0) then write(6,*)' Pb d''ouverture du fichier restart' write(6,*)' ierr = ', ierr call exit(1) endif c ierr = aslun(tapphys,'histphy.dic', c . tapphys+1,'histphy.dat',IDRS_CREATE) c if (ierr.ne.0) then c write(6,*)' Pb d''ouverture du fichier physique' c write(6,*)' ierr = ', ierr c call exit(1) c endif c----------------------------------------------------------------------- c temps de depart et de fin: c -------------------------- itau=0 iday=day_ini+itau/day_step time=FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 IF(time.GT.1.) THEN time=time-1. iday=iday+1 ENDIF itaufin = nday*day_step itaufinp1 = itaufin +1 day_end=day_ini+nday PRINT 300, itau,itaufin,day_ini,day_end CALL iniwrite(taphistd,startdrs,day_ini,phis) CALL iniwrite(tapphys,startdrs,day_ini,phis) CALL iniwrite(taprstar,startdrs,day_end,phis) ecripar = .true. dtav=iperiod*dtvr/daysec CALL iniav(taphmoy,day_ini,0.,periodav,phis) c----------------------------------------------------------------------- c initialisation de la temperature de rappel: c ------------------------------------------- IF(physic) THEN c cinitialisation de la temperature de rappel Newtonnien CALL inirappel(teq) c constante de rappel: dtvr/(30 jours) cterad=dtvr/(30.*daysec) ENDIF c----------------------------------------------------------------------- c Debut de l'integration temporelle: c ---------------------------------- 1 CONTINUE CALL SCOPY( ijmllm,vcov,1,vcovm1,1 ) CALL SCOPY( ijp1llm,ucov,1,ucovm1,1 ) CALL SCOPY( ijp1llm,h,1,hm1,1 ) CALL SCOPY( ip1jmp1,pext,1,pextm1,1 ) c z.x.li CALL SCOPY( ijp1llm*nqmx,q,1,qm1,1 ) forward = .true. leapf = .false. dt = dtvr c ... P.Le Van .26/04/94 .... CALL SCOPY ( ip1jmp1,pext,1,finvpold,1 ) CALL filtreg ( finvpold,jjp1,1,-2,.TRUE.,1 ) 2 CONTINUE c----------------------------------------------------------------------- c date: c ----- c gestion des appels de la physique et des dissipations: c ------------------------------------------------------ apphys = .false. statcl = .false. conser = .false. apdiss = .false. IF( purmats ) THEN IF( MOD(itau,iconser) .eq.0.AND. forward ) conser = .true. IF( MOD(itau,idissip ).eq.0.AND..NOT.forward ) apdiss = .true. IF( MOD(itau,iphysiq ).eq.0.AND. forward $ .AND. physic ) apphys = .true. ELSE IF( MOD(itau ,iconser) .eq. 0 ) conser = .true. IF( MOD(itau+1,idissip) .eq. 0 ) apdiss = .true. IF( MOD(itau,iphysiq).eq.0.AND.forward $ .AND. physic ) apphys = .true. END IF c----------------------------------------------------------------------- c calcul des tendances dynamiques: c -------------------------------- CALL geopot (ip1jmp1, h , pks , phis , phi ) CALL caldyn $ (itau,ucov,vcov,h,pext,pks,pksf,phis, $ phi,conser,du,dv,dh,dp,w, pbaru,pbarv, $ time+iday-day_ini) c----------------------------------------------------------------------- c calcul des tendances advection des traceurs (dont l'humidite) c ------------------------------------------------------------- CALL traceur(nqmx,iadv,q,w, pbaru, pbarv, dq ) c----------------------------------------------------------------------- c integrations dynamique: c ----------------------- CALL integrd $ ( nqmx,vcovm1,ucovm1,hm1,pextm1, c z.x.li $ ( nqmx,vcovm1,ucovm1,hm1,qm1,pextm1, $ dv,du,dh,dq,dp, $ vcov,ucov,h,q,pext,phis,finvpold ) c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) c----------------------------------------------------------------------- c ajout des tendances physiques: c ------------------------------ c Ajout des tendances a chaque pas d'integration .... IF(physic) THEN DO l=1,llm DO ij=1,ip1jmp1 h(ij,l)=h(ij,l)-cterad*(h(ij,l)-teq(ij,l)) ENDDO ENDDO call friction(ucov,vcov,iphysiq*dtvr) ENDIF CALL exner(ip1jmp1,pext,aire,pks,pksf) c----------------------------------------------------------------------- c dissipation horizontal et verticales des petites echelles: c ---------------------------------------------------------- IF(apdiss) THEN CALL dissip(vcov,ucov,h,dvdis,dudis,dhdis) CALL addit(ijp1llm,ucov,dudis,ucov) CALL addit(ijmllm,vcov,dvdis,vcov) CALL addit(ijp1llm,h,dhdis,h) END IF c ******************************************************************** c ******************************************************************** c .... fin de l'integration dynamique et physique pour le pas itau .. c ******************************************************************** c ******************************************************************** c preparation du pas d'integration suivant ...... IF ( .not.purmats ) THEN c ........................................................ c .............. schema matsuno + leapfrog .............. c ........................................................ IF(forward. OR. leapf) THEN itau= itau + 1 iday=day_ini+itau/day_step time=FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 IF(time.GT.1.) THEN time=time-1. iday=iday+1 ENDIF ENDIF IF( itau. eq. itaufinp1 ) STOP c----------------------------------------------------------------------- c ecriture du fichier histoire moyenne: c ------------------------------------- IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN IF(itau.EQ.itaufin) THEN iav=1 ELSE iav=0 ENDIF CALL writeav(nqmx,dtav,time+iday-day_ini . ,ucov,vcov,h,q,pext,iav) ENDIF c----------------------------------------------------------------------- c ecriture de la bande histoire: c ------------------------------ IF( MOD(itau,iecri*day_step).eq.0) THEN nbetat = nbetatdem call writedem(taphistd,nqmx,startdrs,time+iday-day_ini, . vcov,ucov,h,q,pext, . phis,nbetat) ENDIF IF(itau.EQ.itaufin) THEN call writedem(taprstar,nqmx,startdrs,0.,vcov,ucov,h,q, . pext,phis, 1) CLOSE(99) c OPEN(99,file='champ_fin',form='unformatted', c . status='unknown') c WRITE(99) ucov,vcov,h,pext,phis c CLOSE(99) ENDIF c----------------------------------------------------------------------- c gestion de l'integration temporelle: c ------------------------------------ IF( MOD(itau,iperiod).eq.0 ) THEN GO TO 1 ELSE IF ( MOD(itau-1,iperiod). eq. 0 ) THEN IF( forward ) THEN c fin du pas forward et debut du pas backward forward = .false. leapf = .false. GO TO 2 ELSE c fin du pas backward et debut du premier pas leapfrog leapf = .true. dt = 2.*dtvr GO TO 2 END IF ELSE c ...... pas leapfrog ..... leapf = .true. dt = 2.*dtvr GO TO 2 END IF ELSE c ........................................................ c .............. schema matsuno ............... c ........................................................ IF( forward ) THEN itau= itau + 1 iday=day_ini+itau/day_step time=FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 IF(time.GT.1.) THEN time=time-1. iday=iday+1 ENDIF forward = .false. IF( itau. eq. itaufinp1 ) STOP GO TO 2 ELSE IF(MOD(itau,iecri*day_step).EQ.0) THEN nbetat = nbetatdem call writedem(taphistd,nqmx,startdrs, . time+iday-day_ini, . vcov,ucov,h,q,pext, . phis,nbetat) ENDIF IF(itau.EQ.itaufin) . call writedem(taprstar,nqmx,startdrs,0.,vcov,ucov,h,q . ,pext,phis,1) forward = .true. GO TO 1 ENDIF END IF ierr = cllun(taphistd) ierr = cllun(taprstar) ierr = cllun(taphmoy) 300 FORMAT('1'/15x'run du pas'i7,2x,'au pas'i7,2x, 'c"est a dire du * jour'i7,3x'au jour'i7//) STOP ENDc======================================================================= *=*=*=*= friction.html =*=*=*=*
SUBROUTINE friction(ucov,vcov,pdt) IMPLICIT NONE c======================================================================= c c c Objet: c ------ c c *********** c Friction c *********** c c======================================================================= #include "dimensions.h" #include "paramet.h" #include "comgeom2.h" #include "control.h" #include "comconst.h" REAL pdt REAL modv(iip1,jjp1),zco,zsi REAL vpn,vps,upoln,upols,vpols,vpoln REAL u2(iip1,jjp1),v2(iip1,jjm) REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm ) INTEGER i,j REAL cfric parameter (cfric=1.e-6) c calcul des composantes au carre du vent naturel do j=1,jjp1 do i=1,iip1 u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) enddo enddo do j=1,jjm do i=1,iip1 v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) enddo enddo c calcul du module de V en dehors des poles do j=2,jjm do i=2,iip1 modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) enddo modv(1,j)=modv(iip1,j) enddo c les deux composantes du vent au pole sont obtenues comme c premiers modes de fourier de v pres du pole upoln=0. vpoln=0. upols=0. vpols=0. do i=2,iip1 zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) vpn=vcov(i,1,1)/cv(i,1) vps=vcov(i,jjm,1)/cv(i,jjm) upoln=upoln+zco*vpn vpoln=vpoln+zsi*vpn upols=upols+zco*vps vpols=vpols+zsi*vps enddo vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi vps=sqrt(upols*upols+vpols*vpols)/pi do i=1,iip1 modv(i,1)=vpn modv(i,jjp1)=vps enddo c calcul du frottement au sol. do j=2,jjm do i=1,iim ucov(i,j,1)=ucov(i,j,1) s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) enddo ucov(iip1,j,1)=ucov(1,j,1) enddo do j=1,jjm do i=1,iip1 vcov(i,j,1)=vcov(i,j,1) s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) enddo enddo RETURN END