1 : C FACOM3 SOURCE CHAT 07/10/29 21:19:29 5940 2 : subroutine facom3(inodfa,itty,icomn,icom,kfatt,itfa,kft) 3 : ************************************************************************** 4 : * 5 : * ENTREES 6 : * inofa : noeuds de l element 7 : * itty : type de l element 8 : * icomn : tableau contenant les pts communs (en desordre) 9 : * 10 : * icom nombre de points communs 11 : * 12 : * SORTIES 13 : * itfa(n) tableau des faces de ivol1 a tester il y en a kft 14 : * kft nombre de face a tester 15 : * 16 : * 17 : *************************************************************************** 18 : IMPLICIT INTEGER(I-N) 19 : IMPLICIT REAL*8(A-H,O-Z) 20 : 21 : 22 : -INC CCOPTIO 23 : -INC SMELEME 24 : -INC CCGEOME 25 : C dimension ivole(8,1) 26 : dimension inodfa(*),kfatt(*),itfa(*),icomn(*) 27 : 28 : 29 : if(idim.eq.3) then 30 : 31 : nbfa1 = ltel(1,itty) 32 : iltad = ltel(2,itty) 33 : C write(6,*) ' nombre de faces ', nbfa1, ' iltad ',iltad 34 : C write(6,*) ' entree' ,(icomn(i),i=1,icom) 35 : 36 : 37 : 38 : do 1 ifac = 1,nbfa1 39 : ityp= ldel(1,iltad+ifac-1) 40 : iad = ldel(2,iltad+ifac-1) 41 : npfac = kdfac(1,ityp) 42 : C write(6,*)' fac ityp iad npfac', ifac ,ityp ,iad,npfac 43 : 44 : 45 : 46 : if(icom.EQ.npfac) then 47 : C -------------on tient une face complete ------------------------- 48 : do 2 kp = 1,npfac 49 : jf1 = inodfa(lfac(iad+kp-1)) 50 : C jf1 =ivole(lfac(iad+kp-1),ivol1) 51 : do 3 jk = 1,icom 52 : C write(6,*)'adr ',lfac(iad+kp-1),'point ',jf1,'ptcom ',icomn(jk) 53 : if(icomn(jk).eq.jf1) then 54 : kfatt(ifac) = kfatt(ifac)+1 55 : if (kfatt(ifac).eq.icom) then 56 : kft=1 57 : itfa(kft) = ifac 58 : goto 1000 59 : endif 60 : endif 61 : 3 continue 62 : C si on arrive ici il y a un malaise 63 : 2 continue 64 : 65 : 66 : elseif(icom.eq.1) then 67 : C ----------------- coin commun ------------------------- 68 : do 40 kp = 1,npfac 69 : jf1 = inodfa(lfac(iad+kp-1)) 70 : C jf1 =ivole(lfac(iad+kp),ivol1) 71 : 72 : do 50 jk = 1,icom 73 : if(icomn(jk).eq.jf1) then 74 : kft=kft+1 75 : itfa(kft) = ifac 76 : if(kft.eq.3) goto 1000 77 : endif 78 : 50 continue 79 : 40 continue 80 : elseif (icom.eq.kdegre(ityp)) then 81 : C else 82 : C ----------------- arete commune ------------------------- 83 : 84 : do 20 kp = 1,npfac 85 : jf1 = inodfa(lfac(iad+kp-1)) 86 : C jf1 =ivole(lfac(iad+kp-1),ivol1) 87 : do 30 jk = 1,icom 88 : if(icomn(jk).eq.jf1) then 89 : kfatt(ifac) = kfatt(ifac)+1 90 : if (kfatt(ifac).EQ.2) then 91 : kft=kft+1 92 : itfa(kft) = ifac 93 : if(kft.eq.2) goto 1000 94 : endif 95 : endif 96 : 30 continue 97 : 20 continue 98 : 99 : endif 100 : 1 continue 101 : 102 : else 103 : C ===========================2D =================== 104 : 105 : C nombre de points par cote 106 : nbpc = kdegre(itty) 107 : C nombre de cotes 108 : nbcot =nbsom(itty) 109 : nbpoi = nbnne(itty) 110 : ini = 0 111 : 112 : if (icom.GT.1) then 113 : 114 : do 100 ifac=1,nbcot 115 : do 101 isa = 1,nbpc 116 : ini = ini+1 117 : if(ini.eq.nbpoi+1) ini = 1 118 : jf1 = inodfa(ini) 119 : do 102 jk=1,icom 120 : if(icomn(jk).eq.jf1) then 121 : kfatt(ifac)=kfatt(ifac)+1 122 : if (kfatt(ifac).eq.2) then 123 : kft=1 124 : itfa(kft) = ifac 125 : goto 1000 126 : endif 127 : endif 128 : 102 continue 129 : 101 continue 130 : ini = ini-1 131 : 100 continue 132 : 133 : elseif(icom.eq.1) then 134 : 135 : C on a un point commun on cherche les 2 segments 136 : jk=icomn(1) 137 : do 140 ifac=1,nbcot 138 : do 141 isa=1,nbpc 139 : ini = ini+1 140 : if(ini.eq.nbpoi+1) ini = 1 141 : jf1=inodfa(ini) 142 : if(jf1.eq.jk) then 143 : kft=kft+1 144 : itfa(kft) = ifac 145 : if(kft.eq.2) goto 1000 146 : endif 147 : 148 : 141 continue 149 : ini = ini -1 150 : 140 continue 151 : 152 : 153 : endif 154 : endif 155 : 156 : 1000 continue 157 : C write(6,*) ' face ou cote ',(itfa(ik),ik=1,kft) 158 : 159 : return 160 : end 161 : 162 : 163 : 164 : 165 :
© Cast3M 2003 - All rights reserved.
Disclaimer