Télécharger pplan.eso

Retour à la liste

Numérotation des lignes :

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales