c=======================================================================
*=*=*=*= newstart.html =*=*=*=*
PROGRAM newstart c======================================================================= c c c Auteur: 01/1997 c ------ c c c Objet: Creation d'un etat initial pour le GCM martien c ----- (fichiers DRS start et startfi) c c c####################################################################### c ATTENTION!!!! c entrer les valeurs exactes de la grille du fichier "start_archive": c en affectant imold, jmold, lmold dans lect_start_archive.F c puis compiler avec la resolution attendue c####################################################################### c c c======================================================================= implicit none #include "dimensions.h" #include "../phymars/dimphys.h" #include "../phymars/surfdat.h" #include "../phymars/dimradmars.h" #include "../phymars/yomaer.h" #include "../phymars/planete.h" #include "paramet.h" #include "comconst.h" #include "comvert.h" #include "comgeom2.h" #include "control.h" #include "logic.h" #include "drsdef.h" #include "description.h" #include "ener.h" #include "temps.h" #include "lmdstd.h" c======================================================================= c Declarations c======================================================================= c Variables dimension du fichier "start_archive" c------------------------------------ CHARACTER relief*3 c Fonctions DRS: c-------------- INTEGER cluvdb,setname,getdat c et autres: c---------- INTEGER lnblnk,drsread EXTERNAL lnblnk,drsread c Variables pour les lectures DRS des fichiers "start_archive" c-------------------------------------------------- INTEGER unit_ini INTEGER unit_ini_fi INTEGER size INTEGER r4 parameter (r4 = IDRS_BYTES_PER_WORD) INTEGER length parameter (length = 100) INTEGER tab0 INTEGER NB_ETATMAX parameter (NB_ETATMAX = 100) INTEGER dimord(4) ! tableau contenant l'ordre data dimord /1,2,3,4/ ! de sortie des dimensions REAL date REAL p_rad,p_omeg,p_g,p_mugaz,p_daysec c Variable histoire c------------------ REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants REAL h(iip1,jjp1,llm),pext(iip1,jjp1) REAL phis(iip1,jjp1) REAL q(iip1,jjp1,llm,nqmx) ! champs advectes c autre variables dynamique nouvelle grille c------------------------------------------ REAL pks(iip1,jjp1),pksf(iip1,jjp1) REAL w(iip1,jjp1,llm+1) REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) REAL dv(ip1jm,llm),du(ip1jmp1,llm) REAL dh(ip1jmp1,llm),dp(ip1jmp1) REAL phi(iip1,jjp1,llm) c!-*- integer klatdat,klongdat PARAMETER (klatdat=180,klongdat=360) c Physique sur grille scalaire c---------------------------- real zmeaS(iip1,jjp1),zstdS(iip1,jjp1) real zsigS(iip1,jjp1),zgamS(iip1,jjp1),ztheS(iip1,jjp1) c!-*- c variable physique c------------------ REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx),co2ice(ngridmx) REAL emis(ngridmx) REAL q2(ngridmx,nlayermx+1) c REAL phisfi(ngridmx),rnaturfi(ngridmx) REAL rnaturfi(ngridmx) real alb(iip1,jjp1),albfi(ngridmx) real ith(iip1,jjp1),ithfi(ngridmx) REAL latfi(ngridmx),lonfi(ngridmx),airefi(ngridmx) INTEGER i,j,l,idum INTEGER unit REAL xx c REAL year_day,periheli,aphelie,peri_day c REAL obliquit,z0,emin_turb,lmixmin c REAL emisice(2),albedice(2),tauvis,tauir,scatalb,asfact REAL tauir,scatalb,asfact c REAL iceradius(2) , dtemisice(2) EXTERNAL RAN1 REAL RAN1 EXTERNAL iniconst,geopot,inigeom integer aslun, cllun integer ierr, nbetat integer ismin external ismin LOGICAL startdrs c Variable nouvelle grille naturelle au point scalaire c------------------------------------------------------ REAL p(iip1,jjp1) REAL t(iip1,jjp1,llm) real phisold_newgrid(iip1,jjp1) c Variable de l'ancienne grille (lu dans newgridmars.data) c--------------------------------------------------------- real time real tab_cntrl(100) real tab_cntrl_bis(100) c variables diverses c------------------- integer choix_1 character*80 fich_ini character*80 fich_ini_fi integer Lmodif,iq character modif*20 real z_reel(iip1,jjp1) real tsud,alb_bb,ith_bb real ptoto,patm,airetot,ptotn,patmn real ssum c======================================================================= c Lecture du tab_cntrl c======================================================================= write(*,*) 'A partir de quoi souhaitez vous creer vos etats', . ' initiaux ?' write(*,*) ' 0 - d un fichier start_archive' write(*,*) ' 1 - d un fichier start' write(*,*) ' 2 - de rien' c write(*,*) ' 3 - d un fichier histoire' c----------------------------------------------------------------------- c Ouverture des fichiers (start ou start_archive ou histoire) c----------------------------------------------------------------------- unit_ini = 88 unit_ini_fi = 90 124 read(*,*,iostat=ierr) choix_1 if(ierr.ne.0) goto 124 if (choix_1.eq.0) then write(*,*) 'Creation d un etat initial a partir de' write(*,*) './start_archive.dat et ./start_archive.dic' write(*,*) fich_ini_fi = 'start_archive' ierr = aslun(unit_ini_fi, . fich_ini_fi(1:lnblnk(fich_ini_fi))//'.dic', unit_ini_fi+1, . fich_ini_fi(1:lnblnk(fich_ini_fi))//'.dat',IDRS_READ) tab0 = 50 Lmodif = 1 else if (choix_1.eq.1) then write(*,*) 'Creation d un etat initial a partir de' write(*,*) './start.dat et ./start.dic' write(*,*) './startfi.dat et ./startfi.dic' write(*,*) fich_ini = 'start' fich_ini_fi = 'startfi' ierr = aslun(unit_ini,fich_ini(1:lnblnk(fich_ini))//'.dic', . unit_ini+1,fich_ini(1:lnblnk(fich_ini))//'.dat',IDRS_READ) ierr = aslun(unit_ini_fi, . fich_ini_fi(1:lnblnk(fich_ini_fi))//'.dic', unit_ini_fi+1, . fich_ini_fi(1:lnblnk(fich_ini_fi))//'.dat',IDRS_READ) tab0 = 0 Lmodif = 0 else if (choix_1.eq.2) then write(*,*) 'Creation d un etat initial a partir de rien' write(*,*) tab0 = 0 ! tab0 ne sert a rien dans ce cas car pas de lecture unit = 0 Lmodif = 0 c else if (choix_1.eq.3) then c write(*,*) 'Creation d un etat initial a partir de' c write(*,*) './histoire.dat et ./histoire.dic' c write(*,*) './histfi.dat et ./histfi.dic' c write(*,*) c fich_ini = 'histoire' c fich_ini_fi = 'histfi' c ierr = aslun(unit_ini,fich_ini(1:lnblnk(fich_ini))//'.dic', c . unit_ini+1,fich_ini(1:lnblnk(fich_ini))//'.dat',IDRS_READ) c c ierr = aslun(unit_ini_fi, c . fich_ini_fi(1:lnblnk(fich_ini_fi))//'.dic', unit_ini_fi+1, c . fich_ini_fi(1:lnblnk(fich_ini_fi))//'.dat',IDRS_READ) c tab0 = 0 c Lmodif = 1 else goto 124 endif c----------------------------------------------------------------------- c Lecture DRS du tableau des parametres du run (pour la dynamique) c----------------------------------------------------------------------- if (choix_1.eq.0) then write(*,*) 'lecture tab_cntrl START_ARCHIVE' ierr = CLUVDB() ierr = SETNAME(' ','controle',' ',' ',' ') size = r4 * length ierr = GETDAT(unit_ini_fi, tab_cntrl, size) else if (choix_1.eq.1) then write(*,*) 'lecture tab_cntrl START' ierr = CLUVDB() ierr = SETNAME(' ','controle',' ',' ',' ') size = r4 * length ierr = GETDAT(unit_ini, tab_cntrl, size) write(*,*) '1ere impression de tab_cntrl' do i=1,100 write(*,*) i,tab_cntrl(i) enddo write(*,*) 'lecture tab_cntrl STARTFI' ierr = CLUVDB() ierr = SETNAME(' ','controle',' ',' ',' ') size = r4 * length ierr = GETDAT(unit_ini_fi, tab_cntrl_bis, size) do i=1,50 tab_cntrl(i+50)=tab_cntrl_bis(i) enddo write(*,*) '2ere impression de tab_cntrl', tab_cntrl do i=1,100 write(*,*) i,tab_cntrl(i) enddo endif c----------------------------------------------------------------------- c Initialisation des constantes dynamique c----------------------------------------------------------------------- c if (imold.ne.tab_cntrl(1)) then c print 1,imold,tab_cntrl(1) c stop c else if (jmold.ne.tab_cntrl(2)) then c print 2,jmold,tab_cntrl(2) c stop c else if (lmold.ne.tab_cntrl(3)) then c print 3,lmold,tab_cntrl(3) c stop c ENDIF if (choix_1.eq.0 .or. choix_1.eq.1) then kappa = tab_cntrl(9) etot0 = tab_cntrl(12) ptot0 = tab_cntrl(13) ztot0 = tab_cntrl(14) stot0 = tab_cntrl(15) ang0 = tab_cntrl(16) else if (choix_1.eq.2) then kappa = .256793 etot0 = 0. ptot0 = 0. ztot0 = 0. stot0 = 0. ang0 = 0. endif c----------------------------------------------------------------------- c Lecture du tab_cntrl et initialisation des constantes physiques c - pour start: Lmodif = 0 => pas de modifications possibles c (modif dans le tabfi de readfi + loin) c - pour start_archive: Lmodif = 1 => modifications possibles c - pour rien: Lmodif = 0 et unit = 0 => initialisation par defaut dans tabfi c----------------------------------------------------------------------- if (choix_1.eq.0 .or. choix_1.eq.1) then call tabfi (unit_ini_fi,Lmodif,tab0,1,day_ini,lmax,p_rad, . p_omeg,p_g,p_mugaz,p_daysec) ierr = cllun(unit_ini) ierr = cllun(unit_ini_fi) else if (choix_1.eq.2) then call tabfi (0,Lmodif,tab0,1,day_ini,lmax,p_rad, . p_omeg,p_g,p_mugaz,p_daysec) endif rad = p_rad omeg = p_omeg g = p_g mugaz = p_mugaz daysec = p_daysec c======================================================================= c INITIALISATIONS DIVERSES c======================================================================= c Initialisations diverses c ------------------------ day_step=180 startdrs=.true. OPEN(99,file='run.def',status='old',form='formatted') CALL defrun_new(99, .TRUE. ) CLOSE (99) CALL iniconst CALL inigeom idum=-1 xx=RAN1(idum) idum=0 c Initialisation coordonnees /aires c ------------------------------- latfi(1)=rlatu(1) lonfi(1)=0. DO j=2,jjm DO i=1,iim latfi((j-2)*iim+1+i)=rlatu(j) lonfi((j-2)*iim+1+i)=rlonv(i) ENDDO ENDDO latfi(ngridmx)=rlatu(jjp1) lonfi(ngridmx)=0. CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi) c======================================================================= c Lecture des fichiers (start ou start_archive ou histoire) c======================================================================= if (choix_1.eq.0) then write(*,*) 'lecture Fichier START_ARCHIVE' CALL lect_start_archive(date,tsurf,tsoil,emis,q2, . t,ucov,vcov,pext,co2ice,h,phisold_newgrid) else if (choix_1.eq.1) then ! c'est l'appel a tabfi de readfi qui ! permet de changer les valeurs du ! tab_cntrl write(*,*) 'lecture Fichier START' CALL lectba(startdrs,nqmx,vcov,ucov,h,q,pext,phis,time) write(*,*) 'lecture Fichier STARTFI' CALL readfi(fich_ini_fi,tab0,1,ngridmx,nsoilmx,startdrs, . day_ini,time,co2ice,tsurf,tsoil,emis,q2) c scopy(ngridmx,albedodat,1,albfi,1) c scopy(ngridmx,inertiedat,1,ithfi,1) do i=1,ngridmx albfi(i) = albedodat(i) ithfi(i) = inertiedat(i) enddo else if (choix_1.eq.2) then write(*,*) 'initialisation des champs CREATE_START_ARCHIVE' CALL create_start_archive(tsurf,tsoil,emis,q2, . t,ucov,vcov,pext,co2ice,h,phisold_newgrid) else if (choix_1.eq.3) then write(*,*) 'lecture Fichier HISTOIRE' CALL exit(1) else CALL exit(1) endif c======================================================================= c lecture topographie, albedo, inertie thermique, modif F. Lott c======================================================================= if (choix_1.ne.1) then ! pour ne pas avoir besoin du fichier ! surface.dat dans le cas des start do while((relief(1:3).ne.'con').AND.(relief(1:3).ne.'dtm') . .AND.(relief(1:3).ne.'zsm').AND.(relief(1:3).ne.'pla')) write(*,*) write(*,*) 'choix du relief (con,dtm,zsm,pla)' write(*,*) '(consortium, DTM, Zuber&Smith , lisse)' read(*,fmt='(a3)') relief enddo CALL datareaddrs(relief,phis,alb,ith,zmeaS,zstdS,zsigS,zgamS, . ztheS) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi) c c modif F. Lott c CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zmeaS,zmea) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zstdS,zstd) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zsigS,zsig) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zgamS,zgam) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ztheS,zthe) endif c======================================================================= c c======================================================================= 888 continue write(*,*) write(*,*) write(*,*) 'Autres Modifications possibles :' write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' write(*,*) write(*,*) 'bilball : relief, albedo, inertie thermique uniforme' write(*,*) 'coldstart : sous-sol de la calotte sud toujours froid' write(*,*) 'ptot : pression totale' do while(modif(1:1).ne.'hello') write(*,*) write(*,*) 'modification a faire ?' write(*,*) ' (entrer le mot cle ou return pour finir)' write(*,*) read(*,fmt='(a20)') modif if (modif(1:1) .eq. ' ') goto 999 write(*,*) write(*,*) modif(1:lnblnk(modif)) , ' : ' if (modif(1:lnblnk(modif)) .eq. 'bilball') then CALL initial0(ip1jmp1,z_reel) CALL multscal(ip1jmp1,z_reel,g,phis) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi) write(*,*) 'topo mise a 0.' write(*,*) 'Valeur constante pour albedo et iner.therm:' write(*,*) 'Nouvelle valeur pour albedo (ex: 0.25):' 101 read(*,*,iostat=ierr) alb_bb if(ierr.ne.0) goto 101 write(*,*) write(*,*) ' albedo uniforme (nouvelle valeur):',alb_bb write(*,*) write(*,*) 'Nouvelle valeur pour iner.therm (ex: 247):' 102 read(*,*,iostat=ierr) ith_bb if(ierr.ne.0) goto 102 write(*,*) 'iner.therm uniforme (nouvelle valeur):',ith_bb DO j=1,jjp1 DO i=1,iip1 alb(i,j) = alb_bb ith(i,j) = ith_bb END DO END DO CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi) CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi) else if (modif(1:lnblnk(modif)) .eq. 'coldstart') then write(*,*)'nouvelle valeur de la temperature du', & 'sous sol de la calotte permanente sud ? (ex: 141 K)' 103 read(*,*,iostat=ierr) tsud if(ierr.ne.0) goto 103 write(*,*) write(*,*) ' nouvelle valeur de la temperature:',tsud do l=2,nsoilmx tsoil(ngridmx,l) = tsud end do else if (modif(1:lnblnk(modif)) .eq. 'ptot') then c calcul de la pression totale glace + atm actuelle patm=(ssum(ip1jmp1,pext,1)-ssum(jjp1,pext,iip1)) ptoto=(ssum(ip1jmp1,pext,1)-ssum(jjp1,pext,iip1)) . +co2ice(1)*g*ssum(iip1,aire(1,1),1) . +co2ice(ngridmx)*g*ssum(iip1,aire(1,jjp1),1) do j=2,jjp1 do i=1,iim ptoto=ptoto+co2ice((j-2)*iim+i+1)*g*aire(i,j) enddo enddo airetot=(ssum(ip1jmp1,aire,1)-ssum(jjp1,aire,iip1)) print*,'Pression totale au sol actuelle ',ptoto/airetot print*,'nouvelle valeur?' read(*,*) ptotn ptotn=ptotn*airetot patmn=ptotn-ptoto+patm print*,'ptoto,patm,ptotn,patmn' print*,ptoto,patm,ptotn,patmn print*,'Facteur mult de la pression', patmn/patm do j=1,jjp1 do i=1,iip1 pext(i,j)=pext(i,j)*patmn/patm enddo enddo else goto 888 end if end do 999 continue c======================================================================= c Correction de la pression pour nouvelle grille (menu 0) c======================================================================= if (choix_1.eq.0 .or. choix_1.eq.2) then r = 1000.*8.31/mugaz write(*,*) 'mugaz et r(gaz) dans newstart',mugaz,r do j=1,jjp1 do i=1,iip1 pext(i,j) = pext(i,j) * . exp((phisold_newgrid(i,j)-phis(i,j)) / . (t(i,j,1) * r)) end do end do c periodicite de pext en longitude do j=1,jjp1 pext(1,j) = pext(iip1,j) end do end if c======================================================================= c Reajustement de h avec la nouvelle pression c======================================================================= if (choix_1.eq.0 .or. choix_1.eq.2) then do l=1,llm do j=1,jjp1 do i=1,iip1 h(i,j,l) = h(i,j,l) * . exp(-kappa*(phisold_newgrid(i,j)-phis(i,j)) / . (t(i,j,1) * r)) end do h(1,j,l) = h(iip1,j,l) ! periodicite end do end do end if c======================================================================= c Initialisation pour ecriture des NEWSTART et NEWSTARTFI c======================================================================= c----------------------------------------------------------------------- c Initialisation pks,pksf: c----------------------------------------------------------------------- DO j=1,jjp1 DO i=1,iip1 pks(i,j) =p(i,j)**kappa pksf(i,j)=pks(i,j) ENDDO ENDDO c----------------------------------------------------------------------- c Initialisation des champ de traceur: c----------------------------------------------------------------------- Chris attention: mise a 0 des q (traceurs) c DO iq =1, nqmx c DO l=1,llm c DO j=1,jjp1 c DO i=1,iip1 c q(i,j,l,iq)=0. c ENDDO c ENDDO c ENDDO c ENDDO c======================================================================= c Initialisation de la physique / ecriture de newstartfi : c======================================================================= unit=92 ierr = aslun(unit,'newstartfi.dic', . unit+1,'newstartfi.dat',IDRS_CREATE) if (ierr.ne.0) then write(6,*)' Pb d ouverture du fichier newstartfi. Existe deja ?' write(6,*)' ierr = ', ierr call exit(1) endif if (choix_1.eq.0) day_ini = int(date) CALL ini_fi(ngridmx,llm,unit,startdrs, $ day_ini,time,daysec, 0.,0., $ latfi,lonfi,airefi,phisfi,rnaturfi, $ albfi,ithfi, $ rad,g,r,cpp,mugaz,omeg,tsurf,tsoil,co2ice, $ year_day,periheli,aphelie,peri_day, $ obliquit,z0,emin_turb,lmixmin, $ emissiv,emisice,albedice, $ tauvis,tauir,scatalb,asfact, $ emis ,iceradius,dtemisice,q2, c!-*- $ zmea,zstd,zsig,zgam,zthe) c!-*- ierr=cllun(unit) c======================================================================= c ecriture du fichier de demarage: newstart c======================================================================= CALL inifilr CALL exner(ip1jmp1,pext,aire,pks,pksf) CALL geopot (ip1jmp1, h , pks , phis , phi ) CALL caldyn $ (0,ucov,vcov,h,pext,pks,pksf,phis, $ phi,.true.,du,dv,dh,dp,w, pbaru,pbarv,0.) PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang' PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang c----------------------------------------------------------------------- unit=12 IF(startdrs) THEN ierr = aslun(unit,'newstart.dic', . unit+1,'newstart.dat',IDRS_CREATE) ELSE OPEN(unit,file='newstart',form='unformatted',status='new', . iostat=ierr) ENDIF if (ierr.ne.0) then write(6,*)' Pb de creation du fichier newstart. Existe deja ?' write(6,*)' ierr = ', ierr call exit(1) endif CALL iniwrite(unit,startdrs,day_ini,phis) call WRITEDEM(unit,nqmx,startdrs,time,vcov,ucov,h,q,pext, . phis,nbetat) ierr = cllun(unit) c======================================================================= c Formats c======================================================================= 1 FORMAT(//10x'la valeur de im =',i4,2x,'lue sur le fichier de dema *rrage est differente de la valeur parametree iim ='i4//) 2 FORMAT(//10x'la valeur de jm =',i4,2x,'lue sur le fichier de dema *rrage est differente de la valeur parametree jjm ='i4//) 3 FORMAT(//10x'la valeur de lmax =',i4,2x,'lue sur le fichier demar *rage est differente de la valeur parametree llm ='i4//) endc=======================================================================