1 : C CFND SOURCE CHAT 11/03/16 21:16:41 6902 2 : subroutine cfnd 3 : implicit real*8(a-h,o-z) 4 : implicit integer (i-n) 5 : * rendre un chpoint compatible avec des relations de conformités 6 : -INC CCOPTIO 7 : -INC SMMODEL 8 : -INC SMELEME 9 : -INC SMCHPOI 10 : -INC SMRIGID 11 : -INC CCGEOME 12 : -INC CCHAMP 13 : -INC SMCOORD 14 : -INC SMLMOTS 15 : logical ltelq 16 : pointeur nomid1.nomid 17 : segment icpr(xcoor(/1)/(idim+1)) 18 : * write(6,*) ' entree dans depcom' 18 : call lirobj('MMODEL ',mmode1,1,iretou) 19 : if(ierr.ne.0) return 19 : call lirobj('CHPOINT ',mchpo1,1,iretou) 20 : if(ierr.ne.0) return 21 : segini,mmodel=mmode1 22 : segini,mchpoi=mchpo1 23 : icofo=0 24 : do ia=1,kmodel(/1) 25 : imodel=kmodel(ia) 26 : segact imodel 27 : if(nefmod.eq.22) then 28 : icofo=icofo+1 29 : kmodel(icofo)=imodel 30 : else 31 : segdes imodel 32 : endif 33 : enddo 34 : if(icofo.eq.0) then 35 : segsup mmodel 36 : segdes mchpoi 36 : call ecrobj('CHPOINT ',mchpoi) 37 : return 38 : endif 39 : * 40 : * il existe des relations de conformités 41 : * 42 : * 43 : * verif le chpoint n'a qu'une seule zone 44 : segini,mchpoi=mchpo1 45 : if(ipchp(/1).ne.1) then 45 : call erreur (21) 46 : segsup mchpoi 47 : return 48 : endif 49 : msoupo=ipchp(1) 50 : segact msoupo 51 : * 52 : * on fabrique les matrices de liaisons et un maillage contenant 53 : * les noeuds dépendants 54 : * 55 : nrigel=icofo 56 : nrige=8 57 : segini ri6 58 : nbnn=1 59 : nbsous=0 60 : nbref=0 61 : do ia=1,icofo 62 : nbelea=nbelem 63 : imodel=kmodel(ia) 64 : ipt2=imamod 65 : 66 : SEGACT IPT2 67 : nbelem=ipt2.num(/2) 68 : segini meleme 69 : do ib=1,nbelem 70 : num(1,ib)=ipt2.num(2,ib) 71 : enddo 72 : if(ia.eq.1) then 73 : ipt1=meleme 74 : else 75 : ltelq=.false. 75 : call fuse (ipt1,meleme,ipt3,ltelq) 76 : ipt1=ipt3 77 : endif 78 : IF (IPT2.ICOLOR(1).EQ.1) IDEBUT=1 79 : IF (IPT2.ICOLOR(1).EQ.2) IDEBUT=3 80 : IF (IPT2.ICOLOR(1).EQ.3) IDEBUT=6 81 : IF (IPT2.ICOLOR(1).EQ.4) IDEBUT=10 82 : IF (IPT2.ICOLOR(1).EQ.5) IDEBUT=16 83 : IF (IPT2.ICOLOR(1).EQ.6) IDEBUT=24 84 : C==================== 85 : C *** SEGMENT XMATRI 86 : C==================== 87 : NLIGRD=IPT2.NUM(/1) 88 : NLIGRP=NLIGRD 89 : nelrig=ipt2.num(/2) 90 : SEGINI XMATR6 91 : do 34 i=1,nelrig 92 : DO 36 ICAZ=3,IPT2.NUM(/1) 93 : XMATR6.RE(1,ICAZ,i)=XCOEFF(IDEBUT-3+ICAZ) 94 : XMATR6.RE(ICAZ,1,i)=XMATR6.RE(1,ICAZ,i) 95 : 36 CONTINUE 96 : XMATR6.RE(1,2,i)=-1 97 : xmatr6.re(2,1,i)=-1 98 : 34 continue 99 : *C==================== 100 : *C *** SEGMENT IMATRI 101 : *C==================== 102 : * NELRIG=IPT2.NUM(/2) 103 : * SEGINI IMATR6 104 : * DO 34 I=1,IMATR6.IMATTT(/1) 105 : * IMATR6.IMATTT(I)=XMATR6 106 : * 34 CONTINUE 107 : C==================== 108 : C *** SEGMENT DESCR 109 : C==================== 110 : NLIGRD=IPT2.NUM(/1) 111 : NLIGRP=NLIGRD 112 : SEGINI DES1 113 : NEXIST=0 114 : nomid1=lnomid(1) 115 : segact nomid1 116 : DO 33 I=1,LNOMDD 117 : IF (NOMDD(I).EQ.nomid1.lesobl(1)) NEXIST = I 118 : 33 CONTINUE 119 : segdes nomid1 120 : IF (NEXIST.EQ.0) RETURN 121 : DES1.LISINC(1)='LX ' 122 : DES1.LISDUA(1)='FLX ' 123 : DES1.NOELEP(1)=1 124 : DES1.NOELED(1)=1 125 : DO 35 I=2,NLIGRD 126 : DES1.LISINC(I)=NOMDD(NEXIST) 127 : DES1.LISDUA(I)=NOMDU(NEXIST) 128 : DES1.NOELEP(i)=i 129 : DES1.NOELED(i)=i 130 : 35 CONTINUE 131 : C==================== 132 : C *** SEGMENT MRIGID 133 : C==================== 134 : RI6.ICHOLE=0 135 : RI6.IMGEO1=0 136 : RI6.IMGEO2=0 137 : RI6.IFORIG=0 138 : RI6.ISUPEQ=0 139 : RI6.COERIG(ia)=1 140 : RI6.IRIGEL(1,ia)=IPT2 141 : RI6.IRIGEL(2,ia)=0 142 : RI6.IRIGEL(3,ia)=DES1 143 : RI6.IRIGEL(4,ia)=xMATR6 144 : RI6.IRIGEL(5,ia)=0 145 : RI6.IRIGEL(6,ia)=0 146 : RI6.IRIGEL(7,ia)=0 147 : RI6.IRIGEL(8,ia)=0 148 : enddo 149 : 149 : call depen3(ri6,iri1) 149 : * call prrigi(iri1,0) 150 : * write(6,*) ' chpoint initial' 150 : * call ecchpo (mchpoi,0) 150 : call mucpri (mchpoi,iri1,mchpo2) 151 : * write(6,*) ' chpoint apres mucpri' 151 : * call ecchpo (mchpo2,0) 151 : call reduir(mchpoi,ipt1,mchpo3) 152 : * write(6,*) ' valeurs initiales à reajuster' 152 : * call ecchpo(mchpo3,0) 152 : call adchpo (mchpoi,mchpo3,mchpo4,1.d0,-1.d0) 152 : call adchpo(mchpo4,mchpo2,irat, 1.d0,1.d0) 153 : if(irat.eq.0) return 154 : * write(6,*) ' sortie de depcom' 154 : * call ecchpo(irat,0) 154 : call ecrobj('CHPOINT',irat) 155 : return 156 : end 157 : 158 : 159 : 160 : 161 : 162 : 163 :
© Cast3M 2003 - All rights reserved.
Disclaimer