1 : C SUPCHA SOURCE PV 10/10/13 21:15:45 6781 2 : SUBROUTINE SUPCHA 3 : c 4 : c sous routine pour calculer le chargement 5 : c sur les ddl maitres d'un super element 6 : c option CHAR de SUPE 7 : c 8 : c 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8(A-H,O-Z) 11 : c 12 : -INC CCOPTIO 13 : -INC SMELEME 14 : -INC SMRIGID 15 : -INC SMSUPER 16 : -INC SMMATRI 17 : -INC SMVECTD 18 : -INC SMCHPOI 19 : -INC TMTRAV 20 : c 21 : CHARACTER*4 INC 22 : SEGMENT NOHAR(0) 23 : SEGMENT SNOMIN 24 : CHARACTER*4 NOMIN(0) 25 : ENDSEGMENT 26 : SEGMENT SNOMDU 27 : CHARACTER*4 NOMDU(0) 28 : ENDSEGMENT 29 : c 30 : c 31 : c 31 : CALL LIROBJ ('SUPERELE',MSUPER,1,IRETOU) 32 : IF(IERR.NE.0) RETURN 32 : CALL LIROBJ ('CHPOINT ',MCHPOI,1,IRETOU) 33 : IF(IERR.NE.0) RETURN 34 : SEGACT MSUPER 35 : c 36 : c 37 : c *** mcrout contient la decomposition modifiee de la rigidite 38 : c 39 : MMATRI=MCROUT 40 : c 41 : c *** lecture de la geometrie et du descripteur lies a 42 : c *** la matrice de rigidite condensee du superelement 43 : c 44 : MRIGID=MSURAI 45 : SEGACT MRIGID 46 : nbelem=0 47 : nbnn=1 48 : nbsous=0 49 : nbref=0 50 : segini ipt5 51 : ipt5.itypel=1 52 : in=0 53 : do ir=2,irigel(/2) 54 : meleme=irigel(1,ir) 55 : segact meleme 56 : nbelem=nbelem+num(/2) 57 : segadj ipt5 58 : do ip=1,num(/2) 59 : in=in+1 60 : ipt5.num(1,in)=num(1,ip) 61 : enddo 62 : enddo 62 : * call ecmail(ipt5,0) 63 : segact ipt5 64 : ichr=0 64 : if (nbelem.ne.0) call reduir(mchpoi,ipt5,ichr) 65 : lagdua=msuper.islag 66 : * write (6,*) ' supcha msurai ',msurai,lagdua 67 : xMATRI=IRIGEL(4,1) 68 : IPT1=IRIGEL(1,1) 69 : segact ipt1 69 : * call ecmail(ipt1) 70 : DESCR=IRIGEL(3,1) 71 : SEGACT DESCR 72 : SEGINI SNOMIN,SNOMDU,NOHAR 73 : NOMIN(**)=LISINC(1) 74 : NOMDU(**)=LISDUA(1) 75 : NOHAR(**)=IRIGEL(5,1) 76 : DO 10 I=1,LISINC(/2) 77 : N=NOMIN(/2) 78 : DO 11 J=1,N 79 : IF(LISINC(I).EQ.NOMIN(J)) GO TO 10 80 : 11 CONTINUE 81 : NOMIN(**)=LISINC(I) 82 : NOMDU(**)=LISDUA(I) 83 : NOHAR(**)=IRIGEL(5,1) 84 : 10 CONTINUE 85 : c 86 : c *** dimension de la matrice condensee 87 : c 88 : SEGACT xMATRI 89 : * XMATRI=IMATTT(1) 90 : * SEGACT XMATRI 91 : NLIGRA=RE(/1) 92 : * SEGDES XMATRI 93 : SEGDES xMATRI 94 : c 95 : c *** transformation du chpoint en vecteur 96 : c 97 : mchpo1=mchpoi 98 : if (lagdua.ne.0) then 98 : call copie2(mchpoi,mchpo1) 99 : SEGACT MCHPO1 100 : DO 432 I=1,mchpo1.IPCHP(/1) 101 : MSOUPO=mchpo1.IPCHP(I) 102 : SEGACT MSOUPO*MOD 103 : IPT4=IGEOC 104 : SEGINI,ipt5=ipt4 105 : SEGDES ipt4 106 : IGEOC=ipt5 107 : 432 CONTINUE 107 : call dbbch(mchpo1,lagdua) 107 : * call ecmail(lagdua,0) 107 : * call ecchpo(mchpo1,0) 108 : endif 108 : CALL CHV2(MMATRI,MCHPO1,MVECTD,1) 109 : c 110 : c *** calcul du chargement condense 111 : c 112 : 113 : SEGACT MVECTD*MOD 114 : SEGACT MMATRI 115 : MILIGN=IILIGN 116 : SEGACT MILIGN 117 : NBNNMA=IPNO(/1)-NLIGRA 118 : NNOEU=ILIGN(/1) 119 : ILA=1 120 : 121 : 122 : * attention à la normalisation 123 : MDNOR=IDNORM 124 : SEGACT MDNOR 125 : * boucle sur les ddl s 126 : * write (6,*) ' vectbb -0 ',(vectbb(i),i=1,ipno(/1)) 127 : * write (6,*) ' dnor ',(dnor (i),i=1,ipno(/1)) 128 : DO 45 I = 1,IPNO(/1) 129 : VECTBB(I)=VECTBB(I)*DNOR(I) 130 : 45 CONTINUE 131 : * write (6,*) ' vectbb -1 ',(vectbb(i),i=1,ipno(/1)) 132 : 133 : * fin normalisation 134 : 135 : c 136 : DO 1 I=1,NNOEU 137 : LIGN=ILIGN(I) 138 : SEGACT LIGN 139 : NA=IMMM(/1) 140 : IDEB=1 141 : LPREC=0 142 : DO 2 J=1,NA 143 : IFIN=IPPVV(J+1)-1 144 : IDEB2=IVPO(2*IDEB) 145 : LONG=IVPO(2*(IFIN+1)-1)-IVPO(2*IDEB-1) 146 : IPRECOL=ILA-LONG 147 : DO 21 INDIC=IDEB,IFIN 148 : IFIN2=IVPO(2*(INDIC+1))-1 149 : ICOL=IVPO(2*INDIC-1)+IPRECOL-LPREC 150 : IF (ICOL.GT.NBNNMA) GOTO 22 151 : AUX=0.D0 152 : DO 23 K=IDEB2,IFIN2 153 : IF(ICOL.EQ.ILA) GOTO 24 154 : IF(ICOL.GT.NBNNMA) GOTO 24 155 : AUX=AUX+VAL(K)*VECTBB(ICOL) 156 : ICOL=ICOL+1 157 : 23 CONTINUE 158 : 24 CONTINUE 159 : VECTBB(ILA)=VECTBB(ILA)-AUX 160 : IDEB2=IFIN2+1 161 : 21 CONTINUE 162 : 22 CONTINUE 163 : ILA=ILA+1 164 : IDEB=IFIN+1 165 : LPREC=LPREC+LONG 166 : 2 CONTINUE 167 : SEGDES LIGN 168 : 1 CONTINUE 169 : SEGDES MILIGN 170 : c 171 : c *** creation du chpoint resultat 172 : c 173 : SEGACT IPT1 174 : NNNOE=IPT1.NUM(/1) 175 : NNIN=NOMDU(/2) 176 : SEGINI MTRAV 177 : DO 4 I=1,NNNOE 178 : IGEO (I)=IPT1.NUM(I,1) 179 : 4 CONTINUE 180 : DO 5 I=1,NNIN 181 : INCO(I)=NOMDU(I) 182 : NHAR(I)=NOHAR(I) 183 : 5 CONTINUE 184 : DO 6 I=1,NLIGRA 185 : INOEU=NOELED(I) 186 : INC=LISDUA(I) 187 : DO 7 J=1,NNIN 188 : IF(INC.EQ.NOMDU(J)) GO TO 8 189 : 7 CONTINUE 190 : 8 CONTINUE 191 : IBIN(J,INOEU)=1 192 : * on oublie pas de denormaliser si les ddl maitres 193 : * ont ete normalisés 194 : BB(J,INOEU)=VECTBB(NBNNMA+I)/DNOR(NBNNMA+I) 195 : 6 CONTINUE 195 : CALL CRECHP(MTRAV,ISOLU) 196 : if (ichr.ne.0) then 196 : call adchpo(isolu,ichr,iret,1.d0,1.d0) 197 : isolu=iret 198 : endif 199 : c 200 : c champ de nature discrete 201 : c 202 : MCHPOI = ISOLU 203 : SEGACT, MCHPOI*MOD 204 : JATTRI(1)=2 204 : * call ecmail(lagdua) 205 : * write (6,*) ' avant dbbcf dans supcha ' 205 : * call ecchpo(mchpoi) 205 : if (lagdua.ne.0) call dbbcf(mchpoi,lagdua) 206 : * write (6,*) ' apres dbbcf dans supcha ' 206 : * call ecchpo(mchpoi) 207 : 208 : SEGDES MCHPOI 209 : c 210 : ISOLU = MCHPOI 210 : CALL ECROBJ('CHPOINT ',ISOLU) 211 : SEGDES MDNOR 212 : SEGDES DESCR 213 : SEGDES MMATRI 214 : SEGDES MSUPER 215 : SEGDES MRIGID 216 : SEGDES IPT1 217 : SEGSUP SNOMIN,SNOMDU,NOHAR,MVECTD,MTRAV 218 : RETURN 219 : END 220 : c 221 : 222 : 223 :
© Cast3M 2003 - All rights reserved.
Disclaimer