1 : C CHIMI1 SOURCE CHAT 05/01/12 21:57:28 5004 2 : SUBROUTINE CHIMI1 3 : C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 4 : C 5 : C OPERATEUR CHI1 6 : C 7 : C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 8 : IMPLICIT INTEGER(I-N) 9 : IMPLICIT REAL*8(A-H,O-Z) 10 : -INC CCOPTIO 11 : -INC SMTABLE 12 : -INC SMLENTI 13 : -INC SMTEXTE 14 : SEGMENT IDSCHI 15 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 16 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 17 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 18 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 19 : ENDSEGMENT 20 : SEGMENT IZIADR 21 : INTEGER IADR(NCR) 22 : ENDSEGMENT 23 : POINTEUR MLIDEN.MLENTI 24 : CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR 25 : CHARACTER*72 CHARB,CHARL,CHART 26 : LOGICAL LTEMPE,LOGIR,LOGRE 27 : C 28 : MLENT3=0 29 : LIMP3=0 30 : IRETOU=0 31 : MTAB1=0 31 : CALL LIROBJ('TABLE',MTAB1,0,IRETOU) 32 : IF(IRETOU.EQ.0)THEN 32 : CALL LIROBJ('OBJET',MTAB1,1,IRETOU) 33 : * write(6,*)' mtab1 ',mtab1 34 : IF(IRETOU.EQ.0)RETURN 35 : ENDIF 36 : C ON LIT LES ADRESSES DE LA BASE DE DONNEE 37 : IOCHI1=0 38 : IOCHI2=0 39 : IOCHI3=0 40 : LBB=0 41 : LBL=0 42 : LBT=0 43 : DO 10 I=1,3 43 : CALL LIRCHA(CHARR,0,IRETOU) 44 : IF(IRETOU.EQ.0)GO TO 11 45 : IF(CHARR(1:6).EQ.'COMP')THEN 45 : CALL LIRENT(IVAL,0,IRETOU) 46 : IF(IRETOU.EQ.1)IOCHI1=IVAL 46 : CALL LIRCHA(CHARB,0,LBB) 47 : ELSEIF(CHARR(1:4).EQ.'LOGK')THEN 47 : CALL LIRENT(IVAL,0,IRETOU) 48 : IF(IRETOU.EQ.1)IOCHI2=IVAL 48 : CALL LIRCHA(CHARL,0,LBL) 49 : ELSEIF(CHARR(1:4).EQ.'ENTH')THEN 49 : CALL LIRENT(IVAL,0,IRETOU) 50 : IF(IRETOU.EQ.1)IOCHI3=IVAL 50 : CALL LIRCHA(CHART,0,LBT) 51 : ELSE 52 : MOTERR(1:6)='COMP' 52 : CALL ERREUR(396) 53 : RETURN 54 : ENDIF 55 : 10 CONTINUE 56 : 11 CONTINUE 57 : IF(IOCHI1.EQ.0)THEN 58 : IF(LBB.EQ.0)THEN 59 : MOTERR(1:4)='COMP' 59 : CALL ERREUR(396) 60 : RETURN 61 : ELSE 62 : IOCHI1=80 63 : ENDIF 64 : ENDIF 65 : IF(LBB.NE.0)THEN 65 : CALL CHIDBD(IOCHI1,CHARB) 66 : ENDIF 67 : IF(LBL.NE.0)THEN 68 : IF(CHARB(1:LBB).EQ.CHARL(1:LBL))THEN 69 : IOCHI2=IOCHI1 70 : ELSE 71 : IF(IOCHI2.EQ.0)IOCHI2=IOCHI1+1 71 : CALL CHIDBD(IOCHI2,CHARL) 72 : ENDIF 73 : ELSE 74 : IF(IOCHI2.EQ.0)IOCHI2=IOCHI1 75 : ENDIF 76 : IF(LBT.NE.0)THEN 77 : IF(CHART(1:LBT).EQ.CHARL(1:LBL))THEN 78 : IOCHI3=IOCHI2 79 : ELSE 80 : IF(IOCHI3.EQ.0)IOCHI3=IOCHI2+1 80 : CALL CHIDBD(IOCHI3,CHART) 81 : ENDIF 82 : ELSE 83 : ENDIF 84 : C 85 : SEGACT MTAB1 86 : IVALI=1 87 : XVALI=0.D0 88 : IRETI=0 89 : IVALR=0 90 : XVALR=0.D0 91 : IRETR=0 92 : MTYPI='MOT ' 93 : MTYPR='LISTENTI' 94 : CHARR=' ' 94 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'IDEN',.TRUE.,IRETI, 95 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 96 : IF(IERR.NE.0)RETURN 97 : MLIDEN=IRETR 98 : SEGACT MLIDEN 99 : NLIDEN=MLIDEN.LECT(/1) 100 : SEGDES MLIDEN 101 : LXMX=0 102 : IVALI=1 103 : XVALI=0.D0 104 : IRETI=0 105 : IVALR=0 106 : XVALR=0.D0 107 : IRETR=0 108 : MTYPI='MOT ' 109 : MTYPR=' ' 110 : CHARR=' ' 110 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CHXMX',.TRUE.,IRETI, 111 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 112 : IF(MTYPR.NE.' ')THEN 113 : IF(MTYPR.NE.'LISTENTI')THEN 114 : MOTERR(1:11)='CHXMX ' 115 : MOTERR(12:20)='LISTENTI' 115 : CALL ERREUR(627) 116 : RETURN 117 : ENDIF 118 : LXMX=IRETR 119 : ENDIF 120 : LBDD=0 121 : IVALI=1 122 : XVALI=0.D0 123 : IRETI=0 124 : IVALR=0 125 : XVALR=0.D0 126 : IRETR=0 127 : MTYPI='MOT ' 128 : MTYPR=' ' 129 : CHARR=' ' 129 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'BDD',.TRUE.,IRETI, 130 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 131 : IF(MTYPR.NE.' ')THEN 132 : IF(CHARR.EQ.'MINEQL ')THEN 133 : LBDD=0 134 : ELSEIF(CHARR.EQ.'STRASBG ')THEN 135 : LBDD=1 136 : ELSE 137 : MOTERR(1:11)='BDD ' 138 : MOTERR(12:20)='CONNU ' 138 : CALL ERREUR(627) 139 : RETURN 140 : ENDIF 141 : ENDIF 141 : CALL CHILEC(LBDD,MLIDEN,LXMX,IDSCHI,IOCHI1,IOCHI2) 142 : IF(IERR.NE.0)RETURN 143 : C ON GARDE LA LISTE DES ESPECES SIMPLES DE TYPE 3 143 : CALL CHITR1(IDSCHI,IZIADR,IADH,LBDD) 144 : * WRITE(6,*)'CHILEC et CHITRI faits' 145 : C 146 : IVALI=0 147 : XVALI=0.D0 148 : IRETI=0 149 : IVALR=0 150 : XVALR=0.D0 151 : IRETR=0 152 : MTYPI='MOT ' 153 : MTYPR=' ' 154 : CHARR=' ' 155 : NVCOMP=0 155 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'NVCOMP',.TRUE.,IRETI, 156 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 157 : IF(MTYPR.NE.' ')THEN 158 : IF((MTYPR.NE.'TABLE ').AND.(MTYPR.NE.'OBJET '))THEN 159 : MOTERR(1:11)='NVCOMP ' 160 : MOTERR(12:20)='TABLE ' 160 : CALL ERREUR(627) 161 : RETURN 162 : ENDIF 163 : NVCOMP=IRETR 163 : CALL CHICMP(NVCOMP,IDSCHI) 164 : IF(IERR.NE.0)RETURN 165 : ENDIF 166 : IVALI=0 167 : XVALI=0.D0 168 : IRETI=0 169 : IVALR=0 170 : XVALR=0.D0 171 : IRETR=0 172 : MTYPI='MOT ' 173 : MTYPR=' ' 174 : CHARR=' ' 175 : NVESP=0 175 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'NVESP',.TRUE.,IRETI, 176 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 177 : IF(MTYPR.NE.' ')THEN 178 : IF((MTYPR.NE.'TABLE ').AND.(MTYPR.NE.'OBJET '))THEN 179 : MOTERR(1:11)='NVESP ' 180 : MOTERR(12:20)='TABLE ' 180 : CALL ERREUR(627) 181 : RETURN 182 : ENDIF 183 : NVESP=IRETR 183 : CALL CHIESP(NVESP,IDSCHI) 184 : ENDIF 185 : IVALI=0 186 : XVALI=0.D0 187 : IRETI=0 188 : IVALR=0 189 : XVALR=0.D0 190 : IRETR=0 191 : MTYPI='MOT ' 192 : MTYPR=' ' 193 : CHARR=' ' 194 : NVSOSO=0 195 : * write(6,*)' mtab1 ',mtab1 195 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'NVSOSO',.TRUE.,IRETI, 196 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 197 : IF(MTYPR.NE.' ')THEN 198 : IF((MTYPR.NE.'TABLE ').AND.(MTYPR.NE.'OBJET '))THEN 199 : MOTERR(1:11)='NVSOSO ' 200 : MOTERR(12:20)='TABLE ' 200 : CALL ERREUR(627) 201 : RETURN 202 : ENDIF 203 : NVSOSO=IRETR 204 : * WRITE(6,*)'CHIMI1, NVSOSO=',NVSOSO 204 : CALL CHISOL(NVSOSO,IDSCHI) 205 : ENDIF 206 : IVALI=0 207 : XVALI=0.D0 208 : IRETI=0 209 : IVALR=0 210 : XVALR=0.D0 211 : IRETR=0 212 : MTYPI='MOT ' 213 : MTYPR=' ' 214 : CHARR='LISTENTI' 215 : IZECH=0 215 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'ECHANGE',.TRUE.,IRETI, 216 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 217 : IF(MTYPR.NE.' ')THEN 218 : IZECH=IRETR 218 : CALL CHIECH(IZECH,IDSCHI) 219 : ENDIF 220 : IVALI=0 221 : XVALI=0.D0 222 : IRETI=0 223 : IVALR=0 224 : XVALR=0.D0 225 : IRETR=0 226 : MTYPI='MOT ' 227 : MTYPR=' ' 228 : CHARR='TABLE' 229 : ICLIM=0 230 : MLENT=0 230 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CLIM',.TRUE.,IRETI, 231 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 232 : IF(MTYPR.NE.' ')THEN 233 : ICLIM=IRETR 233 : CALL CHICLM(ICLIM,IDSCHI,IZIADR,MLENT3,LIMP3) 234 : IF(IERR.NE.0)RETURN 235 : ENDIF 236 : LTEMPE=.FALSE. 237 : LTMP=1 238 : LOGIR=.TRUE. 239 : IVALI=1 240 : XVALI=0.D0 241 : IRETI=0 242 : IVALR=0 243 : XVALR=0.D0 244 : IRETR=0 245 : MTYPI='MOT ' 246 : MTYPR=' ' 247 : CHARR=' ' 247 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TEMPERATURE',.TRUE.,IRETI, 248 : * MTYPR,IVALR,XVALR,CHARR,LOGIR,IRETR) 249 : IF(MTYPR.NE.' ')THEN 250 : IF(CHARR.EQ.'OUI')THEN 251 : LTEMPE=.TRUE. 252 : ELSEIF(CHARR.EQ.'NON')THEN 253 : LTEMPE=.FALSE. 254 : ELSEIF(MTYPR.EQ.'ENTIER ')THEN 255 : LTEMPE=.TRUE. 256 : LTMP=IVALR 257 : IF((LTMP.NE.1).AND.(LTMP.NE.2))THEN 258 : MOTERR(1:40)='**********************TEMPERATURE ' 258 : CALL ERREUR(-301) 258 : CALL ERREUR(21) 259 : RETURN 260 : ENDIF 261 : ELSE 262 : MOTERR(1:40)='**********************TEMPERATURE ' 262 : CALL ERREUR(-301) 262 : CALL ERREUR(21) 263 : RETURN 264 : ENDIF 265 : ENDIF 266 : IF(LTEMPE)THEN 267 : IF(IOCHI3.EQ.0)IOCHI3=IOCHI2 268 : ENDIF 269 : SEGDES MTAB1 270 : C ON CREE LA TABLE RESULTAT 270 : CALL CRTABL(MTAB3) 270 : CALL ECCTAB(MTAB3,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,'MOT', 271 : * 0,0.D0,'CHIMI1',.TRUE.,0) 272 : C TABLE DESCHI (DESCRIPTION) 272 : CALL CRTABL(MTAB2) 272 : CALL CHIDES(MTAB2,IDSCHI) 273 : CHARR=' ' 273 : CALL ECCTAB(MTAB3,'MOT',0,0.D0,'DESCHI',.TRUE.,0,'TABLE', 274 : * 0,0.D0,CHARR,.TRUE.,MTAB2) 275 : SEGDES MTAB2 276 : MTAB2=0 276 : CALL CRTABL(MTAB1) 276 : CALL CHIRED(IDSCHI,MTAB1,MTAB2,IZIADR,IADH,MLENT3,LIMP3) 277 : IF(MLENT3.NE.0)THEN 278 : SEGDES MLENT3 279 : ENDIF 280 : IF(IERR.NE.0)RETURN 281 : CHARR=' ' 281 : CALL ECCTAB(MTAB3,'MOT',0,0.D0,'IDEN',.TRUE.,0,'TABLE', 282 : * 0,0.D0,CHARR,.TRUE.,MTAB1) 283 : SEGDES MTAB1 284 : IF(MTAB2.NE.0)THEN 285 : CHARR=' ' 285 : CALL ECCTAB(MTAB3,'MOT',0,0.D0,'REDOX',.TRUE.,0,'TABLE', 286 : * 0,0.D0,CHARR,.TRUE.,MTAB2) 287 : SEGDES MTAB2 288 : ENDIF 289 : IF(LTEMPE)THEN 289 : CALL CRTABL(MTAB1) 289 : CALL CHITET(MTAB1,IDSCHI,LBDD,IOCHI3,LTMP) 290 : CHARR=' ' 290 : CALL ECCTAB(MTAB3,'MOT',0,0.D0,'TEMPE',.TRUE.,0,'TABLE', 291 : * 0,0.D0,CHARR,.TRUE.,MTAB1) 292 : SEGDES MTAB1 293 : ENDIF 294 : REWIND(UNIT=IOCHI1) 295 : CLOSE(UNIT=IOCHI1) 296 : IF(IOCHI1.NE.IOCHI2)THEN 297 : REWIND(UNIT=IOCHI2) 298 : CLOSE(UNIT=IOCHI2) 299 : ENDIF 300 : IF((IOCHI3.NE.IOCHI2).AND.LTEMPE)THEN 301 : REWIND(UNIT=IOCHI3) 302 : CLOSE(UNIT=IOCHI3) 303 : ENDIF 303 : CALL ECROBJ('TABLE',MTAB3) 304 : SEGDES MTAB3 305 : SEGSUP IDSCHI 306 : RETURN 307 : END 308 : 309 : 310 : 311 : 312 : 313 : 314 : 315 : 316 : 317 :
© Cast3M 2003 - All rights reserved.
Disclaimer