1 : C REDU SOURCE CHAT 12/01/17 21:15:55 7248 2 : SUBROUTINE REDU 3 : *_______________________________________________________________________ 4 : * 5 : * sous routine de l'operateur redu qui aiguille suivant la fonctionnalite 6 : * 7 : *_______________________________________________________________________ 8 : * 9 : * declaration 10 : * 11 : IMPLICIT REAL*8(A-H,O-Z) 12 : IMPLICIT INTEGER(I-N) 13 : -INC CCOPTIO 14 : -INC SMELEME 15 : -INC SMNUAGE 16 : -INC SMLMOTS 17 : -INC SMTABLE 18 : -INC SMCHAML 19 : * 20 : INTEGER I,NCOMP,J,IPO,INUA 21 : CHARACTER*4 IMO,charre 22 : LOGICAL logr1 23 : CHARACTER*8 TYPOBJ 24 : character*4 mostri(1) 25 : data mostri/'STRI'/ 26 : * 27 : * executable 28 : * 29 : * 30 : * a-t'on en entrée une table esclave si oui on fusionne 31 : * 32 : * a-t'on le mot strict? 33 : istric=0 33 : call lirmot(mostri,1,istric,0) 34 : * 34 : call lirtab('ESCLAVE',mtable,0,iretou) 35 : if(iretou.ne. 0) then 36 : * write(6,*) ' on fusionne la table esclave' 37 : typobj=' ' 38 : segact mtable 39 : ml=mlotab 40 : ind=mtabii(2) 40 : call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre, 41 : > xvalre,charre,logr1,id1) 42 : if (ierr.ne.0) return 43 : * if (typobj.eq.'CHPOINT'.or.typobj.eq.'MCHAML')then 44 : if (typobj.eq.'MCHAML')then 45 : do i=3,ml 46 : segact mtable 47 : ind=mtabii(i) 47 : call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre, 48 : > xvalre,charre,logr1,id2) 49 : if (ierr.ne.0) return 49 : * if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou) 49 : if (typobj.eq.'MCHAML') call fuschl(id1,id2,iretou) 50 : id1=iretou 51 : enddo 52 : else 53 : write (6,*) ' type ',typobj,' inconnu dans redu ' 53 : call trbac 53 : call erreur(5) 54 : endif 54 : CALL ECROBJ(typobj,id1) 55 : * write(6,*)' on a crée un objet ' , typobj 56 : endif 57 : 58 : * 59 : * reduction d'une rigidite sur un maillage 60 : * 60 : CALL LIROBJ('RIGIDITE',IPrigi,0,IRETOU) 61 : IF(IRETOU.EQ.0) GOTO 10 61 : CALL LIROBJ('MAILLAGE',IMEL,1,IRETOU) 62 : IF(IRETOU.EQ.0) return 62 : call reduri(iprigi,imel,irig1) 63 : if(irig1.eq.0) return 63 : call ecrobj('RIGIDITE', irig1) 64 : return 65 : 10 CONTINUE 66 : * 67 : * redu d'un chpoint sur (meleme ou point) 68 : * 68 : CALL LIROBJ('CHPOINT ',ICHP,0,IRETOU) 69 : IF(IRETOU.EQ.0) GO TO 1 69 : CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU) 70 : IF(IRETOU.EQ.0) THEN 70 : CALL LIROBJ('POINT',IP1,0,IRETOU) 71 : IF (IRETOU.NE.0) THEN 72 : NBNN=1 73 : NBELEM=1 74 : NBREF=0 75 : NBSOUS=0 76 : SEGINI MELEME 77 : ITYPEL=1 78 : NUM(1,1)=IP1 79 : SEGDES MELEME 80 : IMEL=MELEME 81 : ELSE 81 : CALL REFUS 82 : GO TO 1 83 : ENDIF 84 : ENDIF 84 : CALL REDUIR(ICHP,IMEL,IRET) 85 : IF ( IERR .NE. 0) RETURN 85 : CALL ECROBJ('CHPOINT',IRET) 86 : RETURN 87 : * 88 : 1 CONTINUE 89 : * 90 : * redu mchaml sur meleme (ou point) 91 : * 91 : CALL LIROBJ('MCHAML',ICHE,0,IRETOU) 92 : IF(IRETOU.EQ.0) GOTO 2 92 : CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU) 93 : IF(IRETOU.EQ.0) THEN 93 : CALL LIROBJ('POINT',IP1,0,IRETOU) 94 : IF (IRETOU.NE.0) THEN 95 : NBNN=1 96 : NBELEM=1 97 : NBREF=0 98 : NBSOUS=0 99 : SEGINI MELEME 100 : ITYPEL=1 101 : NUM(1,1)=IP1 102 : SEGDES MELEME 103 : IMEL=MELEME 104 : ELSE 104 : CALL REFUS 105 : GOTO 2 106 : ENDIF 107 : ENDIF 107 : CALL REDUIC(ICHE,IMEL,IRET) 108 : IF ( IERR .NE. 0) RETURN 108 : CALL ECROBJ('MCHAML',IRET) 109 : RETURN 110 : * 111 : 2 CONTINUE 112 : * 113 : * redu chamelem sur mmodel 114 : * 114 : CALL LIROBJ('MCHAML',ICHE,0,IRETOU) 115 : IF(IRETOU.EQ.0) GOTO 3 115 : CALL LIROBJ('MMODEL',IPMODL,0,IRETOU) 116 : IF (IRETOU.EQ.0) THEN 116 : CALL REFUS 117 : GO TO 3 118 : ENDIF 118 : CALL REDUAF(ICHE,IPMODL,IPCHM,ISTRIC,IRET,KERRE) 119 : IF ( IRET .NE. 1) THEN 119 : CALL ERREUR(KERRE) 120 : RETURN 121 : ENDIF 122 : * segdes de l'entree 123 : mchelm=iche 124 : segact mchelm 125 : do j=1,ichaml(/1) 126 : mchaml=ichaml(j) 127 : segact mchaml 128 : do k=1,ielval(/1) 129 : melval=ielval(k) 130 : segdes melval 131 : enddo 132 : segdes mchaml 133 : enddo 134 : segdes mchelm 135 : * segdes du resultat 136 : mchelm=ipchm 137 : segact mchelm 138 : do j=1,ichaml(/1) 139 : mchaml=ichaml(j) 140 : segact mchaml 141 : do k=1,ielval(/1) 142 : melval=ielval(k) 143 : segdes melval 144 : enddo 145 : segdes mchaml 146 : enddo 147 : segdes mchelm 148 : * 148 : CALL ECROBJ('MCHAML',IPCHM) 149 : RETURN 150 : * 151 : 3 CONTINUE 152 : * 153 : * redu chpoint sur masq 154 : * 154 : CALL LIROBJ('CHPOINT',ICHP,0,IRETOU) 155 : IF(IRETOU.EQ.0) GO TO 4 155 : CALL LIROBJ('CHPOINT',ICHP1,0,IRETOU) 156 : IF(IRETOU.EQ.0) THEN 156 : CALL REFUS 157 : GO TO 4 158 : ENDIF 158 : CALL REDUCP(ICHP,ICHP1,IRET) 159 : IF(IERR.NE.0) RETURN 159 : CALL ECROBJ('CHPOINT',IRET) 160 : RETURN 161 : * 162 : 4 CONTINUE 163 : * 164 : * redu mmodel sur meleme ou point ou reduit le model de contatct 165 : * au element qui peuvent etre actifs 166 : * 166 : CALL LIROBJ('MMODEL',IPMODL,0,IRETOU) 167 : IF(IRETOU.EQ.0) GOTO 5 167 : CALL LIRCHA(charre,0,ireto) 168 : if(ireto.ne.0) then 169 : if( charre.ne.'CONT' ) then 169 : call refus 170 : else 170 : call redcon(ipmodl,iret) 170 : call ecrobj('MMODEL',iret) 171 : return 172 : endif 173 : endif 173 : CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU) 174 : IF(IRETOU.EQ.0) THEN 174 : CALL LIROBJ('POINT',IP1,0,IRETOU) 175 : IF (IRETOU.NE.0) THEN 176 : NBNN=1 177 : NBELEM=1 178 : NBREF=0 179 : NBSOUS=0 180 : SEGINI MELEME 181 : ITYPEL=1 182 : NUM(1,1)=IP1 183 : SEGDES MELEME 184 : IMEL=MELEME 185 : ELSE 185 : CALL REFUS 186 : GOTO 5 187 : ENDIF 188 : ENDIF 188 : CALL REDUMO(IPMODL,IMEL,IRET) 189 : IF (IRET.NE.0) THEN 189 : CALL ECROBJ('MMODEL',IRET) 190 : ENDIF 191 : RETURN 192 : * 193 : 5 CONTINUE 194 : * 195 : * redu d'un nuage a des composantes 196 : * 196 : CALL LIRCHA(IMO,1,IRETOU) 197 : IF (IRETOU.NE.0) THEN 198 : JGN = 4 199 : JGM = 10 200 : SEGINI MLMOTS 201 : MOTS(1) = IMO 202 : IPO1 = MLMOTS 203 : ENDIF 204 : DO 100 I = 2,100 204 : CALL LIRCHA(IMO,0,IRETOU) 205 : IF (IRETOU.NE.0) THEN 206 : MOTS(I) = IMO 207 : IF (I.GT.10) THEN 208 : JGM = I 209 : SEGADJ MLMOTS 210 : MOTS(I) = IMO 211 : IPO1 = MLMOTS 212 : ENDIF 213 : NCOMP = I 214 : ELSE 215 : NCOMP = I - 1 216 : GOTO 101 217 : ENDIF 218 : 100 CONTINUE 219 : 101 CONTINUE 220 : DO 200 I = 1,NCOMP 221 : DO 201 J = (I + 1),NCOMP 222 : IF (MOTS(I).EQ.MOTS(J)) THEN 222 : CALL ERREUR(674) 223 : RETURN 224 : ENDIF 225 : 201 CONTINUE 226 : 200 CONTINUE 226 : CALL LIROBJ('NUAGE',INUA,1,IRETOU) 227 : MNUAG1 = INUA 228 : IF (IRETOU.EQ.0) GOTO 6 228 : CALL REDNUA(INUA,IPO1,NCOMP,INUAR,IRET) 229 : IF (IRET.NE.0) THEN 229 : CALL ECROBJ('NUAGE',INUAR) 230 : ENDIF 231 : SEGDES MLMOTS 232 : RETURN 233 : * 234 : 6 CONTINUE 235 : c 236 : c pas d operande correcte trouve 237 : c 237 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 238 : IF(IRETOU.NE.0) THEN 238 : CALL ERREUR (39) 239 : ELSE 239 : CALL ERREUR(533) 240 : ENDIF 241 : 242 : RETURN 243 : END 244 : 245 : 246 :
© Cast3M 2003 - All rights reserved.
Disclaimer