1 : C EVOL2 SOURCE FANDEUR 10/12/14 21:16:15 6812 2 : SUBROUTINE EVOL2(IBOO,ILEX,IBOBAS,ICHAN) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C======================================================================= 6 : C ILEX CONTIENT LA SUITE DES CHPOINTS DES CONTRIBUTIONS MODALES. 7 : C POUR LES COUPLES POINTS-COMPOSANTES CONTENUS DANS NUMOO, ON 8 : C RECOMBINE LES MODES ET SOLUTIONS STATIQUES CONTENUS DANS MSOBAS . 9 : C RESULTAT DANS LE(S) LISTREEL KLIST. 10 : C APPELE PAR EVRECO 11 : C SI ICHAN=0 ON TRAVAILLE SUR UN CHPOINT 12 : C SI ICHAN=1 ON TRAVAILLE SUR UN CHAMELEM ET ON LE TRANSFORME EN 13 : C CHPOINT PAR UN APPEL A PELPO 14 : C APPELLE : ERREUR(61,243,18) IANUL PROSC1 15 : C CREATION : 02/04/85 16 : C PROGRAMMEUR : FARVACQUE 17 : C======================================================================= 18 : C 19 : -INC CCOPTIO 20 : -INC SMBASEM 21 : -INC SMCHPOI 22 : -INC SMSOLUT 23 : -INC SMLREEL 24 : -INC SMELEME 25 : -INC SMCOORD 26 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 27 : SEGMENT ICPR1(XCOOR(/1)/(IDIM+1)) 28 : SEGMENT/ITRAV1/( TRAV(LDEPL,N)*D) 29 : SEGMENT/ITRAV2/(TRAVV(LDEPL)*D) 30 : SEGMENT/ITRAV3/(ICC(N),ISS(N),IPP(N),NBB(N)) 31 : SEGMENT IPOS(NSOUP1) 32 : SEGMENT ITRAV(2,LDEPL) 33 : SEGMENT NUMOO 34 : INTEGER NUMO(N),KLIST(N) 35 : CHARACTER*4 NUDDL(N) 36 : ENDSEGMENT 37 : DIMENSION KDEPL(2),IMEL(2) 38 : CHARACTER*4 NUJ 39 : C 40 : NUMOO=IBOO 41 : SEGACT NUMOO 42 : N=NUMO(/1) 43 : MSOBAS=IBOBAS 44 : SEGACT MSOBAS 45 : LDEPL=0 46 : DO 6 ICAS=1,2 47 : KDEPL(ICAS)=0 48 : MSOLUT=IBSTRM(ICAS+1) 49 : IF(MSOLUT.EQ.0) GOTO 6 50 : SEGACT MSOLUT 51 : IF (ICHAN.EQ.0) KDEPL(ICAS)=MSOLIS(5) 52 : IF (ICHAN.EQ.1) KDEPL(ICAS)=MSOLIS(6) 53 : IMEL(ICAS)=MSOLIS(3) 54 : SEGDES MSOLUT 55 : IF(KDEPL(ICAS).EQ.0) THEN 56 : MOTERR(1:8)=ITYSOL 56 : CALL ERREUR(61) 57 : SEGDES MSOBAS 58 : RETURN 59 : ENDIF 60 : MSOLEN=KDEPL(ICAS) 61 : SEGACT MSOLEN 62 : LDEPL=LDEPL+ISOLEN(/1) 63 : SEGDES MSOLEN 64 : 6 CONTINUE 65 : SEGDES MSOBAS 66 : LICPR=XCOOR(/1)/(IDIM+1) 67 : SEGINI ICPR,ICPR1 68 : C 69 : C **** FABRICATION DU TABLEAU ICC-ISS-IPP-NBB POUR CHAQUE PT DE SORTIE 70 : C **** (BOUCLE 30) 71 : C **** FABRICATION DU TABLEAU TRAV(LDEPL,N) DES MODES REDUITS AUX 72 : C **** POINTS DE SORTIE (BOUCLE 40) 73 : C 74 : JJJ=0 75 : SEGINI ITRAV1 76 : DO 50 ICAS=1,2 77 : MSOLEN=KDEPL(ICAS) 78 : IF(MSOLEN.EQ.0) GOTO 50 79 : SEGINI ITRAV3 80 : SEGACT MSOLEN 81 : IF (ICHAN.EQ.0) THEN 82 : MCHPOI=ISOLEN(1) 83 : ELSE 84 : ICHAM=ISOLEN(1) 85 : C* Manque le passage en MCHAML aux noeuds avec le modele !!! 85 : C* CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1) 86 : C* IF (IRET.EQ.0) THEN 86 : C* CALL ERREUR(___) 87 : C* RETURN 88 : C* ENDIF 88 : C* CALL CHAMPO(ICHAM2,2,MCHPOI,IRET) 88 : CALL CHAMPO(ICHAM,2,MCHPOI,IRET) 89 : IF (IRET.EQ.0) RETURN 90 : ENDIF 91 : SEGACT MCHPOI 92 : NSOUPO=IPCHP(/1) 93 : KK=0 94 : DO 30 ISOU=1,NSOUPO 95 : MSOUPO=IPCHP(ISOU) 96 : SEGACT MSOUPO 97 : NC=NOCOMP(/2) 98 : MELEME=IGEOC 99 : SEGACT MELEME 99 : CALL IANUL(ICPR(1),LICPR) 100 : DO 60 NB=1,NUM(/2) 101 : ICPR(NUM(1,NB))=NB 102 : 60 CONTINUE 103 : SEGDES MELEME 104 : DO 61 I=1,N 105 : IF(ICPR(NUMO(I)).NE.0) THEN 106 : KK=KK+1 107 : NBB(KK)=ICPR(NUMO(I)) 108 : NUJ=NUDDL(I) 109 : DO 72 IC=1,NC 110 : IF(NOCOMP(IC).EQ.NUJ) THEN 111 : ICC(KK)=IC 112 : ISS(KK)=ISOU 113 : IPP(KK)=I 114 : GOTO 61 115 : ENDIF 116 : 72 CONTINUE 117 : MOTERR(1:4)=NUJ 117 : CALL ERREUR(243) 118 : C INCOMPATIBILITE POINT_COMPOSANTE 119 : GOTO 5000 120 : ENDIF 121 : 61 CONTINUE 122 : SEGDES MSOUPO 123 : 30 CONTINUE 124 : C 125 : IF(KK.NE.N) THEN 125 : CALL ERREUR(18) 126 : C IL MANQUE DES POINTS 127 : GOTO 5000 128 : ENDIF 129 : C 130 : LDEP=ISOLEN(/1) 131 : MELEME=IMEL(ICAS) 132 : SEGACT MELEME 133 : DO 40 I=1,LDEP 134 : JJJ=JJJ+1 135 : ICPR1(NUM(1,I))=JJJ 136 : IF(I.EQ.1) GOTO 42 137 : IF (ICHAN.EQ.0) THEN 138 : MCHPOI=ISOLEN(I) 139 : ELSE 140 : ICHAM=ISOLEN(I) 141 : C* Manque le passage en MCHAML aux noeuds avec le modele !!! 141 : C* CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1) 142 : C* IF (IRET.EQ.0) THEN 142 : C* CALL ERREUR(___) 143 : C* RETURN 144 : C* ENDIF 144 : C* CALL CHAMPO(ICHAM2,2,MCHPOI,IRET) 144 : CALL CHAMPO(ICHAM,2,MCHPOI,IRET) 145 : IF (IRET.EQ.0) RETURN 146 : ENDIF 147 : SEGACT MCHPOI 148 : 42 CONTINUE 149 : DO 41 IP=1,N 150 : MSOUPO=IPCHP(ISS(IP)) 151 : SEGACT MSOUPO 152 : MPOVAL=IPOVAL 153 : SEGACT MPOVAL 154 : TRAV(JJJ,IPP(IP))=VPOCHA(NBB(IP),ICC(IP)) 155 : SEGDES MPOVAL,MSOUPO 156 : 41 CONTINUE 157 : IF (ICHAN.EQ.0) SEGDES MCHPOI 158 : IF (ICHAN.EQ.1) SEGSUP MCHPOI 159 : 40 CONTINUE 160 : SEGDES MSOLEN,MELEME 161 : SEGSUP ITRAV3 162 : 50 CONTINUE 163 : C 164 : SEGSUP ICPR 165 : C 166 : C **** FABRICATION DE ITRAV(2,LDEPL), ET DE IPOS(NSOUP+1) 167 : C 168 : MSOLEN=ILEX 169 : SEGACT MSOLEN 170 : MCHPOI=ISOLEN(1) 171 : SEGACT MCHPOI 172 : NSOUP=IPCHP(/1) 173 : NSOUP1=NSOUP+1 174 : SEGINI IPOS 175 : SEGINI ITRAV 176 : KK=0 177 : IPOS(1)=0 178 : DO 1 ISOU=1,NSOUP 179 : MSOUPO=IPCHP(ISOU) 180 : SEGACT MSOUPO 181 : MELEME=IGEOC 182 : SEGACT MELEME 183 : DO 2 I=1,NUM(/2) 184 : J=ICPR1(NUM(1,I)) 185 : IF(J.NE.0) THEN 186 : KK=KK+1 187 : ITRAV(1,KK)=I 188 : ITRAV(2,KK)=J 189 : ENDIF 190 : 2 CONTINUE 191 : SEGDES MELEME,MSOUPO 192 : IPOS(ISOU+1)=KK 193 : 1 CONTINUE 194 : SEGSUP ICPR1 195 : C 196 : C **** BOUCLE SUR LES INSTANTS DE LA TABLE 197 : C 198 : MSOLEN=ILEX 199 : SEGACT MSOLEN 200 : LTEM=ISOLEN(/1) 201 : JG=LTEM 202 : DO 99 JJ=1,N 203 : SEGINI MLREEL 204 : KLIST(JJ)=MLREEL 205 : 99 CONTINUE 206 : C 207 : SEGINI ITRAV2 208 : DO 90 L=1,LTEM 209 : MCHPOI=ISOLEN(L) 210 : SEGACT MCHPOI 211 : DO 70 I=1,NSOUP 212 : IF(IPOS(I+1).NE.IPOS(I)) THEN 213 : MSOUPO=IPCHP(I) 214 : SEGACT MSOUPO 215 : MPOVAL=IPOVAL 216 : SEGACT MPOVAL 217 : DO 160 NB=IPOS(I)+1,IPOS(I+1) 218 : TRAVV(ITRAV(2,NB))=VPOCHA(ITRAV(1,NB),1) 219 : 160 CONTINUE 220 : SEGDES MPOVAL,MSOUPO 221 : ENDIF 222 : 70 CONTINUE 223 : SEGDES MCHPOI 224 : DO 162 IP=1,N 224 : CALL PROSC1(TRAVV,TRAV(1,IP),RET,LDEPL) 225 : MLREEL=KLIST(IP) 226 : PROG(L)=RET 227 : 162 CONTINUE 228 : 90 CONTINUE 229 : C 230 : SEGSUP ITRAV 231 : SEGSUP IPOS 232 : SEGSUP ITRAV1,ITRAV2 233 : DO 98 JJ=1,N 234 : MLREEL=KLIST(JJ) 235 : SEGDES MLREEL 236 : 98 CONTINUE 237 : C 238 : SEGDES MSOLEN 239 : 5000 CONTINUE 240 : RETURN 241 : END 242 : 243 :
© Cast3M 2003 - All rights reserved.
Disclaimer