1 : C MEDCHP SOURCE CHAT 11/10/26 22:15:23 7176 2 : subroutine medchp(ifid,nocham,itypch,ncomp,nbnoin,nommaa, 3 : $ iprofi,nprof,ichamp,nbpta,ich,icret) 4 : implicit real*8(a-h,o-z) 5 : implicit integer (i-n) 6 : * 7 : * subroutine pour lire le champ par point de nom nomcha s'il existe 8 : * issu d'un fichier MED 9 : * 10 : * il a ncomp composante, leavaleur sont de type itypch(64bits, entier ..) 11 : * Le retour est ich objet de type itycha 12 : * iprofi stocke les profils deja lus et ichamp contient les noms 13 : * de compiosantes 14 : * ich contient 0 ou le pointeur du chpoint 15 : 16 : -INC CCOPTIO 17 : -INC SMELEME 18 : -INC SMCHPOI 19 : -INC SMCHAML 20 : -INC SMTABLE 21 : segment iprofi 22 : character*32 nompro(m) 23 : integer melem(m) 24 : endsegment 25 : Character*16 cha16a 26 : character*32 cha32a, nommaa,nocham,cha32b,cha32c 27 : character*72 cha72 28 : segment ichamp 29 : character*16 nomcom(nc+1),iunit(nc+1) 30 : endsegment 31 : character*8 itycha,nucham 32 : logical bnoel,nboel 33 : CHARACTER*26 MINU,MAJU 34 : DATA MINU/'abcdefghijklmnopqrstuvwxyz'/ 35 : DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 36 : icret=0 37 : ich=0 38 : * write(6,*) ' *** medchp nb de composantes du champ ',ncomp 39 : * write(6,*) ' les noms des composantes sont : ', 40 : * $ (nomcom(iou),iou=1,ncomp) 41 : nc = ncomp 42 : * i11=1 43 : * 44 : * quelques initialisations 45 : * 46 : * 47 : nat=1 48 : nsoupo=1 49 : nbnn=1 50 : nbsous=0 51 : nbref=0 52 : n=1 53 : nsoupo=1 54 : * 55 : * write(6,*) ' entree dans medchp ' 56 : ** le 3 represente MED_NOEUD 57 : * if(i11.ne.1) write(6,*) ' tou va mal 1' 57 : call efnpdt4(ifid,nocham,3,0,npasdt,icret) 58 : * if(i11.ne.1) write(6,*) ' tou va mal 2' 59 : * write(6,*)'sortie appel efnpdt nb de pas de temps ',npasdt 60 : if(icret.ne.0) then 61 : * write(6,*) ' plouf 13' 61 : call efexit4(-1) 62 : return 63 : endif 64 : if(npasdt.eq.0) then 65 : * write(6,*) ' ce n est pas un chpoint' 66 : return 67 : endif 68 : if( npasdt.gt.1) then 69 : * on stocke les champs dans deux tables resultats ( temps , champoint). 70 : m=npasdt 71 : segini mtable,mtab1 72 : mlotab=m 73 : m=2 74 : segini mtab2 74 : call ecctab(mtab2,'MOT',ii,xv,'CHAMPS',nboel,iob,'TABLE ', 75 : $ ii,xv,itycha,nboel,mtable) 75 : call ecctab(mtab2,'MOT',ii,xv,'INSTANTS',nboel,iob,'TABLE ', 76 : $ ii,xv,itycha,nboel,mtab1) 77 : endif 78 : * if(i11.ne.1) write(6,*) ' tou va mal 3' 79 : nprof=0 80 : ngauss=0 81 : do ib=1,npasdt 82 : segini mchpoi 83 : if( npasdt.gt.1) then 84 : mtabti(ib)='ENTIER' 85 : mtabii(ib)=ib 86 : mtabtv(ib)='CHPOINT' 87 : * mtab1.mtabti(ib)='ENTIER' 88 : * mtab1.mtabii(ib)=ib 89 : * mtab1.mtabtv(ib)='FLOTTANT' 90 : endif 91 : ** 3 pour MED_NOEUD 92 : * write(6,*) ' avant appel à efpdti ' 93 : * if(i11.ne.1) write(6,*) ' tou va mal 4' 94 : i33=3 95 : i00=0 96 : bnoel=.false. 97 : * if(.not.bnoel) write(6,*) 'avant appel efpdti4 bnoel ', bnoel 97 : call efpdti4( ifid,nocham,i33,i00,ib,ngauss,numdt, 98 : & numo,iunit,dt,cha32a,bnoel,nbmaa,icret) 98 : * call efpdti4(ifid, nocham,i33,I00, 99 : * & ib, ngauss, numdt, numo, iunit, 100 : * & dt, cha32a, bnoel, nbmaa, icret) 101 : * write (6,*)' nbmaa bnoel (local)' , nbmaa,bnoel 102 : if( nbmaa.ne.1) then 102 : call erreur (1013) 103 : icret=1 104 : return 105 : endif 106 : if (.not.bnoel)then 107 : * write(6,*) ' bnoel ' , bnoel 107 : call erreur (1012) 108 : icret=1 109 : return 110 : endif 111 : if(icret.ne.0) then 112 : * write(6,*) ' plouf 141' 112 : call efexit4(-1) 113 : return 114 : endif 115 : * write(6,*)'numdt,numo,ngauss,dt',numdt,numo,ngauss,dt 116 : ** 2 pour MED_COMPACT 117 : ** 3 pour MED_NOEUD 118 : * write(6,*) ' avant appel à efnval ' 118 : call efnval4(ifid,nocham,3,0,numdt,numo 119 : $ ,cha32a,2,nval,icret) 120 : * write(6,*) ' apres appel à efnval ',numdt,numo,cha32a 121 : if(icret.ne.0) then 122 : * write(6,*) ' plouf 142' 122 : call efexit4(-1) 123 : return 124 : endif 125 : * write(6,*)' le champ ' , nocham , 'contient', nval,' valeurs' 126 : if(npasdt.gt.1)then 126 : call ecctab(mtab1,'ENTIER',ib,xva,cha16a,nboel,iob, 127 : $ 'FLOTTANT',iob,dt,cha16a,nboel,iob) 128 : endif 129 : n=nval 130 : segini mpoval 131 : ifopoi=ifour 132 : * write(6,*) ' avant appel efchal' 132 : call efchal4(ifid,cha32a,nocham,vpocha,0,0,cha32c,cha32b,2,3, 133 : $ 0,numdt,numo,icret) 134 : * write(6,*)'sortie appel efchal cha32a cha32b ',cha32a,cha32b 135 : if(icret.ne.0) then 136 : * write(6,*) ' plouf 15' 136 : call efexit4(-1) 137 : return 138 : endif 139 : segdes mpoval 140 : segini msoupo 141 : ipoval=mpoval 142 : ipchp(1)=msoupo 143 : jattri(1)=1 144 : segdes mchpoi 145 : do ic=1,nc 146 : nocomp(ic)=nomcom(ic) 147 : enddo 148 : nbelem=n 149 : * write(6,*) ' cha32b ', cha32b 150 : * write(6,*) ' nompro ' , nprof,( nompro(iou),iou=1,nprof) 151 : do ic = 1, nprof 152 : if( cha32b.eq.nompro(ic)) then 153 : igeoc= melem(ic) 154 : go to 555 155 : endif 156 : enddo 157 : nbelem=nval 158 : nbnn=1 159 : nbref=0 160 : nbsous=0 161 : segini meleme 162 : itypel=1 163 : if (cha32b.ne.' ') then 164 : nprof=nprof+1 165 : if(nprof.gt.melem(/1)) then 166 : m=nprof+50 167 : segadj iprofi 168 : endif 169 : * write(6,*) ' avant appel efpfll nb points dans profil',nval 170 : nompro(nprof)=cha32b 170 : call efpfll4(ifid,num,cha32b,icret,num,nbelem) 171 : if(nbnoin.ne.0) then 172 : do iuy=1,nbelem 173 : num(1,iuy)=num(1,iuy)+nbnoin 174 : enddo 175 : endif 176 : * write(6,*) ' sortie appel efpfll profil de nom ' ,cha32b 177 : if(icret.ne.0) then 178 : * write(6,*) ' plouf 16' 178 : call efexit4(-1) 179 : return 180 : endif 181 : else 182 : * write(6,*) 'on prend tous les ' , nbpta , ' points' 183 : do iou=1,nbpta 184 : num(1,iou)=iou+nbnoin 185 : enddo 186 : endif 187 : segdes meleme 188 : if(nprof.ne.0) melem(nprof)=meleme 189 : igeoc=meleme 190 : 555 continue 191 : segdes msoupo 192 : segdes mchpoi 193 : if(npasdt.gt.1) then 194 : mtabiv(ib)=mchpoi 195 : endif 196 : enddo 197 : segsup ichamp 198 : if(npasdt.gt.1) then 199 : segdes mtab1,mtab2, mtable 200 : itycha='TABLE' 201 : ich=mtab2 202 : else 203 : itycha='CHPOINT' 204 : ich=mchpoi 205 : endif 206 : nucham=nocham 207 : do iaux=1,8 208 : IRAL=INDEX(MINU,nocham(IAUX:IAUX)) 209 : IF (IRAL.NE.0) nucham(IAUX:IAUX)=MAJU(IRAL:IRAL) 210 : enddo 211 : * write(6,*) nocham , nucham 212 : * write(6,*) ' on nomme : ' , nucham ,'l objet de type ', itycha 212 : call nomobj(itycha,nucham,ich) 213 : return 214 : end 215 : 216 : 217 : 218 : 219 :
© Cast3M 2003 - All rights reserved.
Disclaimer