1 : C CHIESP SOURCE CHAT 05/01/12 21:57:16 5004 2 : SUBROUTINE CHIESP(NVESP,IDSCHI) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C------------------------------------------------------------------ 6 : C 7 : C PRISE EN COMPTE DE NOUVELLES ESPECES 8 : C 9 : C------------------------------------------------------------------ 10 : -INC SMTABLE 11 : -INC SMLENTI 12 : -INC SMLREEL 13 : -INC CCOPTIO 14 : POINTEUR MLIDEN.MLENTI 15 : SEGMENT IDSCHI 16 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 17 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 18 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 19 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 20 : ENDSEGMENT 21 : CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR 22 : CHARACTER*32 CHARM 23 : LOGICAL LOGRE 24 : INTEGER LINIT 25 : C 26 : NYDIM=IDY(/1) 27 : NXDIM=IDX(/1) 28 : NZDIM=IDZ(/1) 29 : NPDIM=IDP(/1) 30 : MTAB1=NVESP 31 : SEGACT MTAB1 32 : NNESP= MTAB1.MLOTAB 33 : C WRITE(6,*)'CHIESP',NNESP 34 : NBIESP=NNESP 35 : IVALI=0 36 : XVALI=0.D0 37 : IRETI=0 38 : IVALR=0 39 : XVALR=0.D0 40 : IRETR=0 41 : MTYPI='MOT ' 42 : MTYPR=' ' 43 : CHARR=' ' 43 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CLASSE',.TRUE.,IRETI, 44 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 45 : IF(IERR.NE.0)RETURN 46 : SEGACT MTAB1 47 : IF(MTYPR.EQ.'MOT ')THEN 48 : C on a trouvé CLASSE c'est un objet on va compter les indices entier 49 : NBIESP= 0 50 : DO 5 IESP=1,NNESP 51 : C write(6,*)' chiesp',mtabti(iesp),mtabtv(iesp),RMTABI(iesp), 52 : C * MTABII(iesp),MTABIV(iesp),RMTABV(iesp) 53 : IF((MTAB1.MTABTI(IESP)).EQ.'ENTIER') NBIESP= NBIESP+1 54 : 5 CONTINUE 55 : ENDIF 56 : DO 80 IESP=1,NBIESP 57 : IVALI=IESP 58 : XVALI=0.D0 59 : IRETI=0 60 : IVALR=0 61 : XVALR=0.D0 62 : IRETR=0 63 : MTYPI='ENTIER ' 64 : MTYPR=' ' 65 : CHARR=' ' 66 : CHARI=' ' 66 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI, 67 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 68 : IF(IERR.NE.0)RETURN 69 : SEGACT MTAB1 70 : IF((MTYPR.EQ.'TABLE ').OR.(MTYPR.EQ.'OBJET '))THEN 71 : MTAB2=IRETR 72 : SEGACT MTAB2 73 : IVALI=1 74 : XVALI=0.D0 75 : IRETI=0 76 : IVALR=0 77 : XVALR=0.D0 78 : IRETR=0 79 : MTYPI='MOT ' 80 : MTYPR='ENTIER ' 81 : CHARR=' ' 81 : CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'IDEN',.TRUE.,IRETI, 82 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 83 : IF(IERR.NE.0)RETURN 84 : SEGACT MTAB1 85 : IDESP=IVALR 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='FLOTTANT' 94 : CHARR=' ' 94 : CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'LOGK',.TRUE.,IRETI, 95 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 96 : IF(IERR.NE.0)RETURN 97 : SEGACT MTAB1 98 : GKESP=XVALR 99 : IVALI=1 100 : XVALI=0.D0 101 : IRETI=0 102 : IVALR=0 103 : XVALR=0.D0 104 : IRETR=0 105 : MTYPI='MOT ' 106 : MTYPR=' ' 107 : CHARR=' ' 107 : CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'COMP',.TRUE., 108 : * IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 109 : SEGACT MTAB1 110 : IF(MTYPR.EQ.' ')THEN 110 : CALL CHIADY(IDY,NYDIM,IDESP,K) 111 : IF(K.EQ.0) THEN 112 : C WRITE(6,*)' MODIF LOGK DE L ESPECE ',IDESP,' IMPOSSIBLE' 113 : C WRITE(6,*)' CETTE ESPECE N A PAS ÉTÉ RETENUE ' 114 : MOTERR(1:40)='********** NVESP . LOGK ' 114 : CALL ERREUR(-301) 115 : INTERR(1)=IDESP 115 : CALL ERREUR(776) 116 : RETURN 117 : ENDIF 118 : GK(K)=GKESP 119 : ELSEIF(MTYPR.EQ.'LISTENTI')THEN 120 : MLENTI=IRETR 121 : SEGACT MLENTI 121 : CALL CHIADY(IDY,NYDIM,IDESP,K) 122 : IF(K.NE.0) THEN 123 : C WRITE(6,*)' L ESPECE ',IDESP,' EXISTE DEJA ' 124 : INTERR(1)=IDESP 124 : CALL ERREUR(777) 125 : RETURN 126 : ENDIF 127 : IVALI=1 128 : XVALI=0.D0 129 : IRETI=0 130 : IVALR=0 131 : XVALR=0.D0 132 : IRETR=0 133 : MTYPI='MOT ' 134 : MTYPR='ENTIER ' 135 : CHARR=' ' 135 : CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'ITYP',.TRUE.,IRETI, 136 : * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 137 : IF(IERR.NE.0)RETURN 138 : SEGACT MTAB1 139 : ITJP=IVALR 140 : IVALI=1 141 : XVALI=0.D0 142 : IRETI=0 143 : IVALR=0 144 : XVALR=0.D0 145 : IRETR=0 146 : MTYPI='MOT ' 147 : MTYPR='LISTREEL' 148 : CHARR=' ' 148 : CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'STOECH',.TRUE., 149 : * IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 150 : IF(IERR.NE.0)RETURN 151 : SEGACT MTAB1 152 : MLREEL=IRETR 153 : SEGACT MLREEL 154 : IVALI=1 155 : XVALI=0.D0 156 : IRETI=0 157 : IVALR=0 158 : XVALR=0.D0 159 : IRETR=0 160 : MTYPI='MOT ' 161 : MTYPR=' ' 162 : CHARM=' ' 162 : CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'NOMESPECE',.TRUE.,IRETI, 163 : * MTYPR,IVALR,XVALR,CHARM,LOGRE,IRETR) 164 : IF(IERR.NE.0)RETURN 165 : SEGACT MTAB1 166 : C 167 : C ON TRAITE 168 : C 169 : C WRITE(6,*)'CHIESP ',IDESP,ITJP,GKESP,MLENTI,MLREEL 170 : LB=LECT(/1) 171 : LC=PROG(/1) 172 : IF(LB.NE.LC)THEN 173 : MOTERR(1:40)='********** NVESP . STOECH ' 173 : CALL ERREUR(-301) 173 : CALL ERREUR(21) 174 : RETURN 175 : ENDIF 176 : *** VERIF COMPOSITION 177 : DO 20 L=1,LB 178 : IF(LECT(L).NE.0) THEN 179 : IDCK = LECT(L) 179 : CALL CHIADY(IDX,NXDIM,IDCK,K) 180 : IF(K.EQ.0) THEN 181 : C WRITE(6,*)' LE COMPOSANT ',IDCK,' N A PAS ÉTÉ RETENU' 182 : C WRITE(6,*)' LE COMPLEXE ',IDESP,' NE PEUT ETRE FORMÉ ' 183 : MOTERR(1:40)='************ NVESP . COMP ' 183 : CALL ERREUR(-301) 184 : INTERR(1)=IDCK 184 : CALL ERREUR(776) 185 : RETURN 186 : ENDIF 187 : ELSE 188 : GOTO 30 189 : ENDIF 190 : 20 CONTINUE 191 : *** INSERTION 192 : 30 CONTINUE 193 : NN(6)=NN(6)+1 194 : NYDIM=NYDIM+1 195 : SEGADJ IDSCHI 196 : IDY(NYDIM)=IDESP 197 : DO 40 IX=1,LB 198 : IF(LECT(IX).EQ.0) GO TO 50 199 : IDCK = LECT(IX) 199 : CALL CHIADY(IDX,NXDIM,IDCK,IK) 200 : AA(NYDIM,IK)=PROG(IX) 201 : GK(NYDIM) =GKESP 202 : NAMESP(NYDIM)=CHARM 203 : 40 CONTINUE 204 : 50 CONTINUE 205 : * WRITE(6,*)' IDJP ',IDJP,' ITJP ',ITJP 206 : LINIT=6 206 : CALL CHIREX(IDSCHI,IDESP,LINIT,ITJP ) 207 : IF(ITJP.NE.2)THEN 208 : NPDIM=NPDIM+1 209 : SEGADJ IDSCHI 210 : IDP(NPDIM)=IDESP 211 : ENDIF 212 : SEGDES MLENTI,MLREEL 213 : ELSE 214 : MOTERR(1:11)='COMP ' 215 : MOTERR(12:20)='LISTENTI' 215 : CALL ERREUR(627) 216 : RETURN 217 : ENDIF 218 : SEGDES MTAB2 219 : ELSE 220 : MOTERR(1:40)='******** NVESP ??????????? ' 220 : CALL ERREUR(-301) 220 : CALL ERREUR(21) 221 : RETURN 222 : ENDIF 223 : 80 CONTINUE 224 : SEGDES MTAB1 225 : * WRITE(6,*)'IDX',(IDX(I),I=1,NXDIM) 226 : * WRITE(6,*)'IDY',(IDY(I),I=1,NYDIM) 227 : * write(6,*)'chiesp IDP',(idp(i),i=1,npdim) 228 : C WRITE(6,*)'GK',(GK(I),I=1,NYDIM) 229 : C WRITE(6,110)((AA(I,J),I=1,NYDIM),J=1,NXDIM) 230 : 110 FORMAT( 2X ,'AA',(10(1PE10.3))) 231 : 232 : 233 : RETURN 234 : END 235 : 236 : 237 : 238 : 239 : 240 : 241 : 242 :
© Cast3M 2003 - All rights reserved.
Disclaimer