1 : C DFER SOURCE PV 07/11/23 21:16:26 5978 2 : SUBROUTINE DFER 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : -INC SMELEME 6 : -INC CCGEOME 7 : -INC CCOPTIO 8 : -INC SMCOORD 9 : -INC TMTRAV 10 : -INC SMCHPOI 11 : 12 : SEGMENT PAQUET 13 : INTEGER LIGNE(NELEM) 14 : ENDSEGMENT 15 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 16 : SEGMENT IDCP(ITE) 17 : 18 : c write(6,*)'ok' 18 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 19 : IF (IERR.NE.0) RETURN 19 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 20 : IF (IERR.NE.0) RETURN 20 : CALL LIRREE(XVAL,0,iretou) 21 : Zi=0.3 22 : if(iretou.ne.0) ZI=xval 23 : C 24 : C IPT1 MAILLAGE BETON 25 : C IPT2 MAILLAGE FER 26 : C 27 : C Création des lignes 28 : II=IPT2 29 : JJ=0 30 : * write(6,*) ' appel a paqlis' 30 : CALL PAQLIG(II,KK) 31 : * write(6,*) ' ierr ' ,ierr 32 : if(ierr.ne.0) return 33 : PAQUET=KK 34 : segact paquet 35 : * write(6,4732) ( ligne (io),io=1,ligne(/1)) 36 : 4732 format (10i7) 37 : * write(6,*) ' retpur de paqlis' 38 : C 39 : C 40 : ITE=0 41 : SEGACT IPT1 42 : IPT3=IPT1 43 : SEGINI ICPR 44 : DO 1 I=1,MAX(1,IPT1.LISOUS(/1)) 45 : IF (IPT1.LISOUS(/1).NE.0) THEN 46 : IPT3=IPT1.LISOUS(I) 47 : SEGACT IPT3 48 : ENDIF 49 : DO 4 L=1,IPT3.NUM(/2) 50 : DO 3 JJ=1,IPT3.num(/1) 51 : IPOIT=IPT3.NUM(JJ,L) 52 : IF (ICPR(IPOIT).NE.0) GOTO 3 53 : ITE=ITE+1 54 : ICPR(IPOIT)=ITE 55 : 3 CONTINUE 56 : 4 CONTINUE 57 : IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT3 58 : 1 CONTINUE 59 : SEGDES IPT1 60 : NBNN=1 61 : NBELEM=ITE 62 : NBSOUS=0 63 : NBREF=0 64 : SEGINI MELEME 65 : ITYPEL=1 66 : ia=1 67 : DO I=1,ICPR(/1) 68 : IF (ICPR(I).NE.0) then 69 : NUM(1,ia)=I 70 : ia=ia+1 71 : endif 72 : END DO 73 : SEGSUP ICPR 74 : SEGACT PAQUET 75 : NC=1 76 : SEGINI MSOUPO 77 : IGEOC=MELEME 78 : N=NBELEM 79 : SEGINI MPOVAL 80 : DO 6 I=1,NUM(/2) 81 : CHB=0. 82 : J=0 83 : IREF=num(1,i)*(IDIM+1)-IDIM 84 : XP=XCOOR(IREF) 85 : YP=XCOOR(IREF+1) 86 : ZP=XCOOR(IREF+2) 87 : IF (IDIM.EQ.2) THEN 88 : ZP=0. 89 : END IF 90 : c write(*,*)'xp',xp,'yp',yp,'zp',zp 91 : DO WHILE (J.NE.LIGNE(/1)) 92 : J=J+1 93 : DIST=10E15 94 : na=LIGNE(J) 95 : IREFA=NA*(IDIM+1)-IDIM 96 : XA=XCOOR(IREFA) 97 : YA=XCOOR(IREFA+1) 98 : ZA=XCOOR(IREFA+2) 99 : IF (IDIM.EQ.2) THEN 100 : ZA=0. 101 : END IF 102 : j=j+1 103 : if(i.eq.1) then 104 : * write(6,*) ' point de depart ' , na 105 : endif 106 : DO WHILE (LIGNE(J).NE.0) 107 : c write(6,*)ligne(j) 108 : nb=LIGNE(J) 109 : if(i.eq.1) then 110 : * write(6,*) nb 111 : endif 112 : IREFB=NB*(IDIM+1)-IDIM 113 : XB=XCOOR(IREFB) 114 : YB=XCOOR(IREFB+1) 115 : ZB=XCOOR(IREFB+2) 116 : IF (IDIM.EQ.2) THEN 117 : ZB=0. 118 : END IF 119 : 119 : CALL DISTAN(XP,XA,XB,YP,YA,YB,ZP,ZA,ZB, 120 : $ DISTINT,MARQ) 121 : c if (marq.eq.0) then 122 : c write(*,*)'xa',xa,'ya',ya,'za',za 123 : c write(*,*)'xb',xb,'yb',yb,'zb',zb 124 : c end if 125 : IF (MARQ.NE.0) THEN 126 : xl1=((XB-XP)**2+(YB-YP)**2+(ZB-ZP)**2)**0.5 127 : xl2=((XA-XP)**2+(YA-YP)**2+(ZA-ZP)**2)**0.5 128 : DISTINT=MIN(xl1,xl2) 129 : ENDIF 130 : IF (DISTINT.LE.DIST) THEN 131 : DIST=DISTINT 132 : ENDIF 133 : J=J+1 134 : xa=xb 135 : ya=yb 136 : za=zb 137 : END DO 138 : CHB=CHB+XINFLU(DIST,ZI) 139 : c write(6,*)'dist',dist,'influen',XINFLU(DIST,ZI) 140 : c write(6,*)'idcp',idcp(i),'chp',chb 141 : c if (XINFLU(DIST,ZI).ne.0) then 142 : c write(*,*)'xp',xp,'yp',yp,'zp',zp 143 : c write(*,*)'xa',xa,'ya',ya,'za',za 144 : c write(*,*)'xb',xb,'yb',yb,'zb',zb 145 : c write(6,*)jjelem,'chp',chb 146 : c write(6,*)'dist',dist,'influen',XINFLU(DIST,ZI) 147 : c endif 148 : END DO 149 : VPOCHA(I,1)=CHB 150 : 151 : 6 CONTINUE 152 : IPOVAL=MPOVAL 153 : NOCOMP(1)='DFER' 154 : SEGDES MPOVAL 155 : NSOUPO=1 156 : NAT=1 157 : SEGINI MCHPOI 158 : JATTRI(1)=2 159 : IPCHP(1)=MSOUPO 160 : MOCHDE='MANUEL' 161 : SEGDES MSOUPO,meleme 162 : SEGDES IPT2,IPT1 162 : CALL ECROBJ('CHPOINT ',MCHPOI) 163 : RETURN 164 : END 165 : 166 : 167 : 168 : 169 : 170 : 171 : 172 : 173 : 174 : 175 : 176 : 177 : 178 : 179 : 180 : 181 : 182 : 183 : 184 : 185 : 186 : 187 : 188 : 189 : 190 : 191 : 192 :
© Cast3M 2003 - All rights reserved.
Disclaimer