1 : C PPLAN SOURCE PASCAL 08/05/15 21:15:01 6101 2 : C CE SOUS-PROGRAMME RAMENE UN PLAN SUR DES COORDONNEES INTRINSEQUES 3 : C 4 : SUBROUTINE PPLAN(IOP,FER,XPROJ,NDEB,NUMNP,tcval) 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : -INC CCOPTIO 8 : -INC SMCOORD 9 : real*8 tcval(*) 10 : SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR),AFER.FER 11 : SEGMENT XPROJ(3,IMAX) 12 : * tcval (1) 2 3 4 5 6 13 : * COMMON/CPPLAN/XVEC1,YVEC1,ZVEC1,XVEC2,YVEC2,ZVEC2,XNORM,YNORM, 14 : * 15 : * # ZNORM 16 : * 7 8 9 17 : * SAVE XGRAV,YGRAV,ZGRAV 18 : IF (IOP.EQ.2) GOTO 100 19 : ctest=1d-2 19 : if (idim.eq.3) call lirree(ctest,0,iretou) 20 : IMCT=MAI(ITOUR+1) 21 : INCT=MAI(1)+1 22 : IMAX=(IMCT**2)+10 22 : CALL LIRENT(IMAX,0,IRETOU) 23 : IF (IRETOU.NE.0) IMAX=MAX(1,IMAX) 24 : NDEB=IMCT+1 25 : SEGINI XPROJ 26 : SEGACT MCOORD 27 : C CENTRE DE GRAVITE 28 : XGRAV=0 29 : YGRAV=0 30 : ZGRAV=0 31 : DO 1 I=INCT,IMCT 32 : IREF=(NFI(I))*(IDIM+1)-IDIM 33 : XGRAV=XGRAV+XCOOR(IREF) 34 : YGRAV=YGRAV+XCOOR(IREF+1) 35 : ZGRAV=ZGRAV+XCOOR(IREF+2) 36 : 1 CONTINUE 37 : XGRAV=XGRAV/(IMCT-INCT+1) 38 : YGRAV=YGRAV/(IMCT-INCT+1) 39 : ZGRAV=ZGRAV/(IMCT-INCT+1) 40 : IF (IDIM.EQ.2) ZGRAV=0 41 : tcval(7)=xgrav 42 : tcval(8)=ygrav 43 : tcval(9)=zgrav 44 : C VECTEUR NORMAL 45 : XNORM=0 46 : YNORM=0 47 : ZNORM=0 48 : DO 2 IT=1,ITOUR 49 : IPR=NFI(MAI(IT+1))*(IDIM+1)-IDIM 50 : XV1=XCOOR(IPR)-XGRAV 51 : YV1=XCOOR(IPR+1)-YGRAV 52 : ZV1=XCOOR(IPR+2)-ZGRAV 53 : IF (IDIM.EQ.2) ZV1=0 54 : DO 2 I=MAI(IT-1+1)+1,MAI(IT+1) 55 : IREF=(NFI(I))*(IDIM+1)-IDIM 56 : XV2=XCOOR(IREF)-XGRAV 57 : YV2=XCOOR(IREF+1)-YGRAV 58 : ZV2=0 59 : IF (IDIM.GE.3) ZV2=XCOOR(IREF+2)-ZGRAV 60 : XNORM=XNORM+YV1*ZV2-ZV1*YV2 61 : YNORM=YNORM+ZV1*XV2-XV1*ZV2 62 : ZNORM=ZNORM+XV1*YV2-XV2*YV1 63 : XV1=XV2 64 : YV1=YV2 65 : ZV1=ZV2 66 : 2 CONTINUE 67 : DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2) 67 : IF (DNORM.EQ.0.) CALL ERREUR(21) 68 : IF (IERR.NE.0) RETURN 69 : XNORM=XNORM/DNORM 70 : YNORM=YNORM/DNORM 71 : ZNORM=ZNORM/DNORM 72 : C FORMATION DU REPERE 73 : IREF=NFI(INCT)*(IDIM+1)-IDIM 74 : XVEC1=XCOOR(IREF)-XGRAV 75 : YVEC1=XCOOR(IREF+1)-YGRAV 76 : ZVEC1=0 77 : IF (IDIM.GE.3) ZVEC1=XCOOR(IREF+2)-ZGRAV 78 : PVEC=XVEC1*XNORM+YVEC1*YNORM+ZVEC1*ZNORM 79 : XVEC1=XVEC1-PVEC*XNORM 80 : YVEC1=YVEC1-PVEC*YNORM 81 : ZVEC1=ZVEC1-PVEC*ZNORM 82 : DVEC1=XVEC1**2+YVEC1**2+ZVEC1**2 83 : DVEC1=SQRT(DVEC1) 84 : XVEC1=XVEC1/DVEC1 85 : YVEC1=YVEC1/DVEC1 86 : ZVEC1=ZVEC1/DVEC1 87 : tcval(1)=xvec1 88 : tcval(2)=yvec1 89 : tcval(3)=zvec1 90 : XVEC2=YNORM*ZVEC1-ZNORM*YVEC1 91 : YVEC2=ZNORM*XVEC1-XNORM*ZVEC1 92 : ZVEC2=XNORM*YVEC1-YNORM*XVEC1 93 : tcval(4)=xvec2 94 : tcval(5)=yvec2 95 : tcval(6)=zvec2 96 : C EN AVANT POUR LA PROJECTION 97 : DO 40 I=INCT,max(IMCT,mai(itour+2)) 98 : II=NFI(I) 99 : NFI(I)=I 100 : IREF=II*(IDIM+1)-IDIM 101 : XRE=XCOOR(IREF)-XGRAV 102 : YRE=XCOOR(IREF+1)-YGRAV 103 : ZRE=XCOOR(IREF+2)-ZGRAV 104 : if (idim.eq.2) zre=0 105 : XPROJ(1,I)=XRE*XVEC1+YRE*YVEC1+ZRE*ZVEC1 106 : XPROJ(2,I)=XRE*XVEC2+YRE*YVEC2+ZRE*ZVEC2 107 : XTEST =XRE*XNORM+YRE*YNORM+ZRE*ZNORM 108 : DRE =SQRT(XRE*XRE+YRE*YRE+ZRE*ZRE) 109 : IF (IDIM.EQ.3.AND.ABS(XTEST).GT.DRE*ctest.AND. 109 : # i.le.imct) CALL ERREUR(26) 110 : IF (IERR.NE.0) RETURN 111 : XPROJ(3,I)=XCOOR(IREF+IDIM) 112 : 40 CONTINUE 113 : C SI LA DENSITE LOCALE N'EST PAS DEFINIE IL FAUT LE FAIRE 114 : DO 41 IT=1,ITOUR 115 : II1=MAI(IT-1+1)+1 116 : II2=MAI(IT+1) 117 : IAP=II2 118 : DO 41 I=II1,II2 119 : IF (XPROJ(3,I).NE.0) GOTO 41 120 : XPROJ(3,I)=SQRT((XPROJ(1,I)-XPROJ(1,IAP))**2+(XPROJ(2,I)-XPROJ(2, 121 : # IAP))**2) 122 : IAP=I 123 : 41 CONTINUE 124 : RETURN 125 : 100 CONTINUE 126 : xvec1=tcval(1) 127 : yvec1=tcval(2) 128 : zvec1=tcval(3) 129 : xvec2=tcval(4) 130 : yvec2=tcval(5) 131 : zvec2=tcval(6) 132 : xgrav=tcval(7) 133 : ygrav=tcval(8) 134 : zgrav=tcval(9) 135 : C ON RECONSTITUE LE MAILLAGE 136 : SEGACT MCOORD 137 : IF (NDEB.GT.NUMNP) GOTO 111 138 : NBPTA=XCOOR(/1)/(IDIM+1) 139 : NBPTS=NBPTA+NUMNP-NDEB+1 140 : SEGADJ MCOORD 141 : DO 110 I=NDEB,NUMNP 142 : XCOOR(NBPTA*(IDIM+1)+1)=XPROJ(1,I)*XVEC1+XPROJ(2,I)*XVEC2+XGRAV 143 : XCOOR(NBPTA*(IDIM+1)+2)=XPROJ(1,I)*YVEC1+XPROJ(2,I)*YVEC2+YGRAV 144 : IF (IDIM.GE.3) 145 : #XCOOR(NBPTA*(IDIM+1)+3)=XPROJ(1,I)*ZVEC1+XPROJ(2,I)*ZVEC2+ZGRAV 146 : XCOOR((NBPTA+1)*(IDIM+1))=XPROJ(3,I) 147 : NBPTA=NBPTA+1 148 : 110 CONTINUE 149 : 111 CONTINUE 150 : SEGSUP XPROJ 151 : RETURN 152 : END 153 : 154 : 155 : 156 : 157 :
© Cast3M 2003 - All rights reserved.
Disclaimer