C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C C LAST MODIF : 07.05.1991 PASSAGE DE 40 MOLECULES A 75 DANS LES COMMON C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C program sgeisa CBB ajout de iuni pour lecture d un autre base que GEISA 29/10/1996 CBB namelist/geisa/ pgm,nu1,nu2,dnu,liste,format,mole,isot,nfff, CBB & modif,nbclas,trans,trs1,trs2,juni,vers,histo,anal namelist/geisa/ pgm,nu1,nu2,dnu,liste,format,mole,isot,nfff, &kuni,iuni,modif,nbclas,trans,trs1,trs2,juni,vers,histo,anal CBB fin des modifs 29/10/96 logical*1 jdh(75),qqq integer vers,p(300000),stime,tarray(9) integer*2 qmot real nu1,nu2 real*8 tod1,cput1,reste,tod2,cput2 character*132 fnt character*112 fml character*80 fmc c character*8 C,clock_,D,date character*24 cdatedeb,cdatefin,ctime integer tempsdeb,tempsfin,time character*44 fmt character*9 trs1,trs2,tabday(7),tabmonth(12) character*7 form,bin,format character*6 fff character*4 inte,base,deux,ctlg,code,mole,histo,blanc character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre, & iopt,liste,modif,anal,iini,iuti,itri,trans, & iasr,remp,supp,ajou,oui,mpgx character*2 ikod,icod character*1 bl,cara(100) C equivalence (p(1),cara(1)) C common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste common/p2/ mole(75),isot(100),nbi(75),nbt(75),iopt,ctlg,trans, & trs1,trs2 common/p3/ imole,iran,ival,pgm,ianl,iext,itrs,ilst,icop,info,icre common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif common/p5/ code(75),nn(150),nq(150),ikod(18),icod(18),jdeb(75) common/p6/ iasr,remp,supp,ajou,imp8,imp9,in40,in41,in42,in43,n97 common/p7/ iremp,isupp,iajou common/p8/ npgx,nfff,mpgx,qqq(75) common/ffff/ fml,fmc,fmt,fnt,fff common/inteh/ incr,pas1,pmax common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui C data inte,base,deux/'inte','base','deux'/ data iini,iuti/'ini','uti'/,itri/'tri'/,bl/' '/ data tabday/'Sunday ','Monday ','Tuesday ','Wednesday', $'Thursday ','Friday ','Saturday '/ data tabmonth/'January ','February ','March ','April ', $'May ','June ','July ','August ','September', $'October ','November ','December '/ include 'geisafile.h' C len=ltrim(racine_data) filename_asc=racine_data(1:len)//'/line_GEISA2003_asc_gs_v1.0' filename_bin=racine_data(1:len)//'/line_GEISA2003_bin_gs_v1.0' write(isor,5) 5 format(/51x,'input instructions supplied to GEISA software', &//26x,82('*')) i=0 10 continue read (ient,11,end=15)(p(j),j=1,20) 11 format(20a4) if(cara(1).ne.bl) i=1 write(isor,12 )(p(j),j=1,20) 12 format(26x,'*',20a4,'*') go to 10 15 continue write(isor,16) 16 format(26x,82('*')) if(i.eq.0) go to 6 write(isor,1010) 1010 format(///' the parameter list begins in column 2', &/' verify this parameter list') go to 200 6 continue rewind ient C C MODIFICATION DE RAYMOND C 25 continue C INITIALISATION DES PARAMETRES vers=03 nmol=42 copy =0. juni=0 format=' ' npgx=0 mpgx=' ' nfff=0 nu1=-1. nu2=-1. dnu=0. nbclas=10 anal=' ' histo=' ' kanal=0 ival=0 mode=-1 modif=' ' trs1=' ' trs2=' ' trans=' ' liste=' ' do 30 j=1,nmol 30 mole(j)=blanc do 31 j=1,ksot 31 isot(j)=0 read (ient,geisa,end=200) jdeb(1)=1 kk=1 do 20 i=2,nmol kk=kk+nn(kk)+1 jdeb(i)=kk 20 continue do 21 j=1,nmol qqq(j)=.false. 21 continue C C LA BANQUE COMPLETE EST TOUJOURS STOCKEES SUR JUNGLE C mpgx=pgm CBB initialisation de iuni,kuni c print *, 'sgeisa iuni=',iuni if(iuni.eq.0) iuni=1 if(kuni.eq.0) kuni=2 c print *, 'sgeisa2 iuni=',iuni CBB fin modif 29/10/96 if(juni.eq.0) juni=10 if(format.eq.bin) open(unit=juni,form='unformatted') if(format.eq.form) then len=ltrim(filename_asc) open(unit=juni,form='formatted', &file=filename_asc(1:len)) endif c i1 = mclock() tempsdeb=time() if(pgm.ne.iini) go to 35 if(iarr.eq.1) go to 150 call init(iuni,isor,pgm,vers) go to 150 35 continue if(pgm.ne.iuti) go to 36 if(iarr.eq.1) go to 150 call utili(p,pgm) go to 150 36 continue lpgm=10 c print *,'pgm=',pgm if(pgm.eq.ianl) lpgm=1 if(pgm.eq.iext) lpgm=2 if(pgm.eq.ilst) lpgm=3 if(pgm.eq.itrs) lpgm=4 if(pgm.eq.icop) lpgm=5 if(pgm.eq.icre) lpgm=6 if(pgm.eq.info) lpgm=7 if(pgm.eq.itri) lpgm=8 npgx=lpgm C ANL EXT LST TRS COP CRE INF TRI go to (40 ,42 ,42 ,42 ,43 ,42 ,75 , 42 ,140),lpgm C OPTION *** ANL *** 40 continue c print *,'format=',format,' anal=',anal if(format.eq.bin) anal=oui if(anal.eq.oui) kanal=1 khist=0 c print *,'histo=',histo if(histo.eq.inte) khist=1 if(histo.eq.base) khist=2 if(histo.eq.deux) khist=-1 if(histo.eq.inte.or.histo.eq.deux) nbclas=13 c print *,'kanal =',kanal,' anal=',anal,' khist=',khist if(kanal.eq.0.and.khist.eq.0) go to 140 c print *,'kanal2=',kanal,' khist=',khist 42 continue if(format.eq.bin) mode=0 if(format.eq.form) mode=1 if(pgm.eq.itri) go to 133 c print *,'modif=',modif if(pgm.eq.icre.or.modif.eq.oui) go to 100 43 continue c print *,'nu1 =',nu1, 'nu2 =',nu2 if(nu1.ge.0..and.nu2.gt.0..and.nu1.lt.nu2) go to 100 write(isor,1000) pgm 1000 format(///' *',a3,'* you must initialize parameter nu1 or nu2'///) go to 150 C C OPTION *** INF *** C 75 continue mode=1 if(anal.eq.oui) pgm=ianl if(trans.eq.oui) pgm=itrs if(pgm.eq.ianl.or.pgm.eq.itrs) go to 100 mode=-1 if(liste.eq.ctlg.and.nu1.gt.nu2) go to 42 100 continue c print *,'format=',format if(format.eq.oui) mode=0 knmol=0 do 105 i=1,nmol if(mole(i).ne.blanc) knmol=knmol+1 105 continue c print *,'knmol =',knmol kksot=0 if(lpgm.gt.3) go to 107 do 106 j=1,ksot if(isot(j).ne.0) kksot=kksot+1 106 continue c print *,'kksot =',kksot 107 continue go to 130 if(dnu.eq.0.) dnu=5. do 110 i=1,nmol do 109 j=1,nmol if(mole(i).eq.code(j)) jdh(j)=.true. 109 continue 110 continue c print *,'sgeisa=',(mole(kl),kl=1,nmol) iuni=kuni call infor(p,p) if(liste.eq.oui) stop 1111 go to 150 130 continue c print *,'appel MOLIS' C call molis(p,jdh,*150) C c print *,'retour MOLIS' do 132 j=1,nmol qqq(j)=jdh(j) 132 continue 133 continue C c print *,'pgm=',pgm if(pgm.eq.info) call infor(p,p(1+ntab)) if(pgm.eq.icop) call copie(p,*150) if(pgm.eq.ianl) &call analy(p,p(1+ntab),p(1+2*ntab),p(1+3*ntab),p(1+4*ntab), &p(1+5*ntab+nmol),p(1+5*ntab+2*nmol),jdh,*150) if(pgm.eq.iext) call extr(p,jdh,*150) if(pgm.eq.ilst) call list(p,jdh,*150) if(pgm.eq.itrs) call trsi(p,p,p,jdh,*150) if(pgm.eq.icre ) call creat(p,*150) if(pgm.eq.itri) call trif(juni,isor,pgm,mode,vers,*150) go to 150 140 continue write(isor,3000) pgm 3000 format(///' *',a3, &'* invalid order &geisa given. program continue'///) 150 continue c print *,' retour:',pgm c i2 = mclock() tempsfin=time() c ktt=i2-i1 c call ltime_(stime,tarray) ktt=tempsfin-tempsdeb c D = date() c C = clock_() cdatedeb=ctime(tempsdeb) cdatefin=ctime(tempsfin) write(isor,4000) cdatedeb,cdatefin,ktt 4000 format(//20x, &'Laboratoire de Meteorologie Dynamique : start : ',a24 &,/63x,'end : ',a24,/62x,'(Real time =',i6,' seconds)') c write(isor,4000) D,C,ktt c4000 format(//20x,'Laboratoire de Meteorologie Dynamique le ',a8, c & ' a ' ,a8,3x,'/',i6,' csecondes/'/20x,37('*') ) C IMPRESSIONS DE LA LISTE DES OPTIONS DISPONIBLES if(pgm.eq.info.and.liste.eq.iopt) go to 75 c if(pgm.ne.iasr) go to 25 200 continue stop end