| 1 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
|---|
| 2 | C |
|---|
| 3 | C LAST MODIF : 07.05.1991 PASSAGE DE 40 A 75 MOLECULES DANS LES COMMON |
|---|
| 4 | C |
|---|
| 5 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
|---|
| 6 | C |
|---|
| 7 | subroutine utili(p,pgm) |
|---|
| 8 | C |
|---|
| 9 | character*7 form,bin |
|---|
| 10 | character*4 code,blanc,kk,ivab(32) |
|---|
| 11 | character*3 modif,pgm,mpgx,oui |
|---|
| 12 | character*2 ikod,icod |
|---|
| 13 | character*1 slash,moins,bl,aster,vb(128),p(1),zk(4) |
|---|
| 14 | logical*1 qqq |
|---|
| 15 | integer vers,njm(12) |
|---|
| 16 | dimension vab(32) |
|---|
| 17 | real*8 nom,nomj |
|---|
| 18 | C |
|---|
| 19 | common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif |
|---|
| 20 | common/p5/ code(75),nn(150),nq(150),ikod(18),icod(18),jdeb(75) |
|---|
| 21 | common/p8/ npgx,nfff,mpgx,qqq(75) |
|---|
| 22 | common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui |
|---|
| 23 | C |
|---|
| 24 | equivalence (vb(1),vab(1),ivab(1),nomj),(kk,zk(1)) |
|---|
| 25 | C |
|---|
| 26 | data njm /31,28,31,30,31,30,31,31,30,31,30,31/ |
|---|
| 27 | data slash,moins,bl,aster/'/','-',' ','*'/ |
|---|
| 28 | C |
|---|
| 29 | nfff=1 |
|---|
| 30 | call pgeisa(0.,99999.) |
|---|
| 31 | read (iuni,rec=1) |
|---|
| 32 | &aa1,aa2,anu,n203,nbraie,nbmol,iecr,ifin,ll1,ll2,ll3,ll4 |
|---|
| 33 | c vers=ll3 |
|---|
| 34 | if(ll1.eq.0.or.ll2.eq.0) go to 300 |
|---|
| 35 | write(isor,1000) pgm,pgm,vers |
|---|
| 36 | 1000 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', |
|---|
| 37 | &31x,' spectroscopic data bank ',32x, |
|---|
| 38 | &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ |
|---|
| 39 | &' * geisa geisa *',26x,15x,'*** GEISA',i2.2,' ***',16x, |
|---|
| 40 | & 26x,'* geisa geisa *'/1x,17('*'),98x,17('*')/ |
|---|
| 41 | & 1x,33x,' management and study of atmospheric spectroscopic |
|---|
| 42 | &informations') |
|---|
| 43 | write(isor,2000) |
|---|
| 44 | 2000 format(//1x,51x,' list of the user records '/// |
|---|
| 45 | &' |',128('-'),'|'/ |
|---|
| 46 | &2x, '| date | nu1 | nu2 |pgm|',30x, |
|---|
| 47 | &' used molecule ',44x,'|') |
|---|
| 48 | lll1=ifin+ll1+ll2 |
|---|
| 49 | lll2=lll1+ll4 |
|---|
| 50 | if(ll4.lt.0) lll2=ifin+ll1+ll2-ll4-1 |
|---|
| 51 | C |
|---|
| 52 | C CODAGE DU TABLEAU VB |
|---|
| 53 | C 1 ---> 8 NOM |
|---|
| 54 | C 9 ---> 15 SIGLE NUM |
|---|
| 55 | C 16 ---> 23 DATE |
|---|
| 56 | C 25 ---> 28 NU1 |
|---|
| 57 | C 29 ---> 32 NU2 |
|---|
| 58 | C 33 ---> 36 PGM |
|---|
| 59 | C 37 ---> 120 MOLECULES |
|---|
| 60 | C |
|---|
| 61 | do 20 lll=lll1,lll2 |
|---|
| 62 | read (iuni,rec=lll) kb,longr,max,nxx,(p(j),j=1,kb) |
|---|
| 63 | if(lll.eq.lll1.and.kb.eq.0) go to 200 |
|---|
| 64 | if(kb.eq.0) go to 20 |
|---|
| 65 | i1=0 |
|---|
| 66 | do 18 i=1,kb,nxx |
|---|
| 67 | i1=i1+1 |
|---|
| 68 | C |
|---|
| 69 | C COPIE DU NOM ET DU SIGLE NUM |
|---|
| 70 | C |
|---|
| 71 | do 5 j=1,15 |
|---|
| 72 | vb(j)= p(i+j-1) |
|---|
| 73 | 5 continue |
|---|
| 74 | C |
|---|
| 75 | C DECODAGE DE LA DATE EN XX/XX/XX |
|---|
| 76 | C |
|---|
| 77 | read (p(i+15),'(i2)') lan |
|---|
| 78 | read (p(i+17),'(i2)') jour |
|---|
| 79 | njm2=njm(2) |
|---|
| 80 | if(mod(lan,4).eq.0) njm(2)=29 |
|---|
| 81 | do 6 j=1,12 |
|---|
| 82 | mois=j |
|---|
| 83 | if(jour.le.njm(j)) go to 7 |
|---|
| 84 | jour=jour-njm(j) |
|---|
| 85 | 6 continue |
|---|
| 86 | 7 continue |
|---|
| 87 | njm(2)=njm2 |
|---|
| 88 | write (jour,'(i2)') vb(16) |
|---|
| 89 | vb(18)=slash |
|---|
| 90 | write (mois,'(i2)') vb(19) |
|---|
| 91 | vb(21)=slash |
|---|
| 92 | write (lan ,'(i2)') vb(22) |
|---|
| 93 | C |
|---|
| 94 | C COPIE DE NU1 ET NU2 ET NOM PROGRAMME |
|---|
| 95 | C |
|---|
| 96 | do 8 j=21,32 |
|---|
| 97 | vb(j+4)=p(i+j-1) |
|---|
| 98 | 8 continue |
|---|
| 99 | C MISE A BLANC DE LA REGION MOLECULE |
|---|
| 100 | C |
|---|
| 101 | do 10 j=10,32 |
|---|
| 102 | ivab(j)=blanc |
|---|
| 103 | 10 continue |
|---|
| 104 | C |
|---|
| 105 | C SI PROGRAMME LEC LAISSER DES BLANCS |
|---|
| 106 | C |
|---|
| 107 | C DECODAGE DES MOLECULES |
|---|
| 108 | C |
|---|
| 109 | i2=36 |
|---|
| 110 | do 14 j=33,nxx |
|---|
| 111 | if(p(i+j-1).eq.'1') go to 14 |
|---|
| 112 | kk=code(j-32) |
|---|
| 113 | do 12 jj=1,4 |
|---|
| 114 | if(zk(jj).eq.bl) go to 13 |
|---|
| 115 | i2=i2+1 |
|---|
| 116 | C NE PAS DEBORDER DANS LE TABLEAU VB |
|---|
| 117 | if(i2.le.128) vb(i2)=zk(jj) |
|---|
| 118 | 12 continue |
|---|
| 119 | 13 continue |
|---|
| 120 | i2=i2+1 |
|---|
| 121 | if(i2.le.128) vb(i2)=moins |
|---|
| 122 | 14 continue |
|---|
| 123 | if(i2.le.128) vb(i2)=bl |
|---|
| 124 | write(juni) vab |
|---|
| 125 | 18 continue |
|---|
| 126 | 20 continue |
|---|
| 127 | end file juni |
|---|
| 128 | rewind juni |
|---|
| 129 | C |
|---|
| 130 | C TRI SELON LES VARIABLES SUIVANTES : |
|---|
| 131 | C NOM - SIGLENUM - ANNEE - MOIS - JOUR . |
|---|
| 132 | C |
|---|
| 133 | c call tri('*sort fields=(5,8,ch,a,13,7,ch,a,26,2,ch,a,23,2,ch,a,20, |
|---|
| 134 | c &2,ch,a)*','*record type=v*',irc) |
|---|
| 135 | C |
|---|
| 136 | if(irc.ne.0) go to 100 |
|---|
| 137 | luni=juni+1 |
|---|
| 138 | rewind luni |
|---|
| 139 | nom=0. |
|---|
| 140 | i=0 |
|---|
| 141 | 35 continue |
|---|
| 142 | read (luni,end=40) vab |
|---|
| 143 | i=i+1 |
|---|
| 144 | if(nom.eq.nomj) go to 37 |
|---|
| 145 | ii=0 |
|---|
| 146 | do 36 j=1,8 |
|---|
| 147 | if(vb(j).ne.bl) ii=ii+1 |
|---|
| 148 | 36 continue |
|---|
| 149 | nom=nomj |
|---|
| 150 | iii=8-ii |
|---|
| 151 | write(isor,2010) nom,(vb(j),j=9,15),(aster,j=1,ii),(bl,j=1,iii) |
|---|
| 152 | 2010 format( ' |',128('-'),'|'/ ' |',128x,'|'/ |
|---|
| 153 | &' |---',a8,5x,7a1,105x,'|'/' | ',8a1,117x,'|'/' |',128('-'), |
|---|
| 154 | &'|') |
|---|
| 155 | 37 continue |
|---|
| 156 | write(isor,2020)(vb(j),j=16,23),vab(7),vab(8),ivab(9), |
|---|
| 157 | &(vb(j),j=37,128) |
|---|
| 158 | 2020 format(' |',8a1,'|',f10.3,'|',f10.3,'|',a3,'|',92a1,' |') |
|---|
| 159 | go to 35 |
|---|
| 160 | 40 continue |
|---|
| 161 | write(isor,2030) |
|---|
| 162 | 2030 format( ' |',128('-'),'|') |
|---|
| 163 | return |
|---|
| 164 | 100 continue |
|---|
| 165 | write(isor,3000) |
|---|
| 166 | 3000 format(///' *uti* error in step sort'///) |
|---|
| 167 | return |
|---|
| 168 | 200 continue |
|---|
| 169 | write(isor,4000) |
|---|
| 170 | 4000 format(///' *uti* record empty, no call to the data bank '//) |
|---|
| 171 | return |
|---|
| 172 | 300 continue |
|---|
| 173 | write(isor,5000) pgm |
|---|
| 174 | 5000 format(///' *',a3,'* trs and anl options must be run with parame |
|---|
| 175 | &ter modif=oui before this call'///) |
|---|
| 176 | return |
|---|
| 177 | end |
|---|
