Télécharger lissag.eso

Retour à la liste

Numérotation des lignes :

  1. C LISSAG SOURCE PV 20/03/30 21:20:52 10567
  2. SUBROUTINE LISSAG
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC SMELEME
  8. -INC SMLREEL
  9. -INC SMCHPOI
  10. -INC SMCOORD
  11. SEGMENT EDICON
  12. INTEGER KSTRT, KSTEP, NMIR, IS
  13. REAL*8 CROT , SROT , SYMFCT
  14. LOGICAL LREAL, LIMAG
  15. ENDSEGMENT
  16. SEGMENT ICPR(nbpts)
  17. SEGMENT IVOISI
  18. INTEGER IVOI(LL,MM),INB(MM)
  19. ENDSEGMENT
  20. SEGMENT ICOO
  21. REAL*8 X(MV),Y(MV),P(MV),WNODE(MV)
  22. INTEGER LISVO(MV)
  23. ENDSEGMENT
  24. SEGMENT IVAL
  25. REAL*8 VAL(nbpts)
  26. ENDSEGMENT
  27. SEGMENT ITRAVA
  28. REAL*8 KENN(M42,2),SIGMA(M42),DELRHO(M42),C(M50,M50)
  29. REAL*8 AK(M50),UM(M50),RM(M50)
  30. INTEGER IL(M50)
  31. ENDSEGMENT
  32. CHARACTER*4 MCLE(3)
  33. DATA MCLE/'PLAN','AXIS','POID'/
  34. IF (IDIM .NE. 2) THEN
  35. CALL ERREUR(19)
  36. RETURN
  37. ENDIF
  38. U=0
  39. UX=1
  40. UY=2
  41. UXX=3
  42. UXY=4
  43. UYY=5
  44. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  45. IF(IERR.NE.0) RETURN
  46. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  47. IF(IERR.NE.0) RETURN
  48. CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
  49. IF(IERR.NE.0) RETURN
  50. CALL LIRENT ( ITYPE,1,IRETOU)
  51. IF(IERR.NE.0) RETURN
  52. CALL LIRMOT ( MCLE,2,ICOOR,1)
  53. IF(IERR.NE.0) RETURN
  54. CALL LIRMOT( MCLE(3),1,IVAL,0)
  55. W1ST=1.
  56. W1ND=1.
  57. IF(IVAL.NE.0) THEN
  58. CALL LIRREE( W1ST,1,IRETOU)
  59. IF(IERR.NE.0) RETURN
  60. CALL LIRREE( W1ND,1,IRETOU)
  61. IF(IERR.NE.0) RETURN
  62. ENDIF
  63. CALL LIROBJ( 'POINT ', IPO,0,IRETOU)
  64. XORG=0.D0
  65. YORG=0.D0
  66. IF(IRETOU.NE.0) THEN
  67. XORG=XCOOR((IPO-1)*(IDIM+1) +1)
  68. YORG=XCOOR((IPO-1)*(IDIM+1) +1)
  69. ENDIF
  70. C
  71. C
  72. C MISE SOUS FORME D'ELEMENTS POINTS DU 2EME MAILLAGE. IL SERVIRA AU
  73. C CHPOINT RESULTAT
  74. C
  75. SEGACT IPT2
  76. CALL CHANGE(IPT2,1)
  77. C WRITE(6,FMT='( '' SORTIE DE CHANGE '')')
  78. C
  79. C IVOI(I,J)=K VEUT DIRE QUE LE IEME VOISIN DU NOEUD J A LENUMERO GLOBAL K
  80. C INB(J)= K VEUT DIRE QUE LE JEME POINT LOCAL A K VOISIN
  81. C
  82. SEGINI ICPR
  83. SEGACT IPT1
  84. MELEME = IPT1
  85. IF(ITYPEL.EQ.1) THEN
  86. CALL ERREUR(16)
  87. RETURN
  88. ENDIF
  89. LIS = MAX(IPT1.LISOUS(/1),1)
  90. MM = 0
  91. DO 2 L=1,LIS
  92. IF(IPT1.LISOUS(/1).NE.0) THEN
  93. MELEME=IPT1.LISOUS(L)
  94. SEGACT MELEME
  95. ENDIF
  96. NBEL= NUM(/2)
  97. NBP= NUM(/1)
  98. DO 3 I=1,NBEL
  99. DO 3 J=1,NBP
  100. IKI =NUM(J,I)
  101. IF(ICPR(IKI).NE.0) GO TO 3
  102. MM = MM + 1
  103. ICPR(IKI) = MM
  104. 3 CONTINUE
  105. IF(IPT1.LISOUS(/1).NE.0) THEN
  106. SEGDES MELEME
  107. ENDIF
  108. 2 CONTINUE
  109. 4 CONTINUE
  110. C INITIALISATION DE LL AU PIFIFL FAUDRA TESTER LES DEBORDEMENTS
  111. IV = NBP - 1
  112. LL= IV * 3
  113. SEGINI IVOISI
  114. MELEME = IPT1
  115. LIS=MAX(1,IPT1.LISOUS(/1))
  116. DO 6 LI=1,LIS
  117. IF(IPT1.LISOUS(/1).NE.0) THEN
  118. MELEME=IPT1.LISOUS(LI)
  119. SEGACT MELEME
  120. ENDIF
  121. DO 7 I=1,NUM(/2)
  122. DO 8 J=1,NUM(/1)-1
  123. IGLO= NUM(J,I)
  124. ILO = ICPR(IGLO)
  125. DO 9 K = J+1,NUM(/1)
  126. IGLA= NUM(K,I)
  127. ILA = ICPR(IGLA)
  128. IF(INB(ILO).GT.0) THEN
  129. DO 10 L=1,INB(ILO)
  130. IF(IVOI(L,ILO).EQ.IGLA) GO TO 9
  131. 10 CONTINUE
  132. ENDIF
  133. INB(ILO)=INB(ILO)+1
  134. INB(ILA)=INB(ILA)+1
  135. IF(INB(ILO).GT.LL.OR.INB(ILA).GT.LL) THEN
  136. LL = LL + IV
  137. SEGADJ IVOISI
  138. ENDIF
  139. IVOI(INB(ILO),ILO)=IGLA
  140. IVOI(INB(ILA),ILA)=IGLO
  141. 9 CONTINUE
  142. 8 CONTINUE
  143. 7 CONTINUE
  144. IF(IPT1.LISOUS(/1).EQ.0) THEN
  145. SEGDES MELEME
  146. ENDIF
  147. 6 CONTINUE
  148. C WRITE(6,FMT='('' ICPR'',/,(10I6))')(ICPR(KJI),KJI=1,27)
  149. C WRITE(6,FMT='('' INB'',/,(10I6))')(INB(KJI),KJI=1,17)
  150. C DO 1234 KL=1,17
  151. C WRITE(6,FMT='('' IVOI'',/,(10I6))')(IVOI(KJI,KL),KJI=1,INB(KL))
  152. C 1234 CONTINUE
  153. SEGINI EDICON
  154. C
  155. C
  156. C ON BOUCLE SUR LES POINTS DU 2EME MAILLAGE LES ETAPES SONT:
  157. C RECHERCHE DU POINT DU MAILLAGE 1 LE PLUS PROCHE
  158. C FABRICATION DE LA PREMIERE COUCHE DE VOISINS
  159. C FABRICATION DE LA DEUXIEME COUCHE DE VOISINS
  160. C FABRICATION DU TABLEAU CONTENANT LES COORDONNEES
  161. C FABRICATIONS DU TABLEAU CONTENANT LES VALEURS DU CHAMP
  162. C APPEL DE LA FONCTION LISSAGE
  163. C REMPLISSAGE DU CHPOINT RESULTAT
  164. C FIN DE BOUCLE
  165. C
  166. C ECLATEMENT DU CHPOINT INITIAL
  167. C
  168. SEGACT MCHPOI
  169. NAT=JATTRI(/1)
  170. IF(IPCHP(/1).NE.1) CALL ERREUR (25)
  171. IF(IERR.NE.0) RETURN
  172. MSOUPO=IPCHP(1)
  173. SEGACT MSOUPO
  174. IPT3=IGEOC
  175. SEGACT IPT3
  176. MPOVAL=IPOVAL
  177. SEGINI IVAL
  178. SEGACT MPOVAL
  179. DO 19 I=1,IPT3.NUM(/2)
  180. IGLO=IPT3.NUM(1,I)
  181. VAL(IGLO)=VPOCHA(I,1)
  182. 19 CONTINUE
  183. SEGDES MPOVAL,IPT3
  184. C CREATION DU CHPOINT RESULTAT
  185. NSOUPO=1
  186. SEGINI MCHPO1
  187. DO 18 II=1,NAT
  188. MCHPO1.JATTRI(II)=JATTRI(II)
  189. 18 CONTINUE
  190. NC=7
  191. SEGINI MSOUPO
  192. MCHPO1.IPCHP(1)=MSOUPO
  193. MCHPO1.IFOPOI=IFOMOD
  194. SEGDES MCHPO1,MCHPOI
  195. NOCOMP(1)='A'
  196. NOCOMP(2)='BX'
  197. NOCOMP(3)='BY'
  198. NOCOMP(4)='BXX'
  199. NOCOMP(5)='BXY'
  200. NOCOMP(6)='BYX'
  201. NOCOMP(7)='BYY'
  202. NOHARM(1)=NIFOUR
  203. NOHARM(2)=NIFOUR
  204. NOHARM(3)=NIFOUR
  205. NOHARM(4)=NIFOUR
  206. NOHARM(5)=NIFOUR
  207. NOHARM(6)=NIFOUR
  208. NOHARM(7)=NIFOUR
  209. IGEOC=IPT2
  210. SEGACT IPT2
  211. N = IPT2.NUM(/2)
  212. SEGINI MPOVAL
  213. IPOVAL=MPOVAL
  214. SEGDES MSOUPO
  215. MV=50
  216. SEGINI ICOO
  217. M42 = 42
  218. M50 = 50
  219. M42 = 84
  220. M50 = 100
  221. SEGINI ITRAVA
  222. IDIM1=IDIM+1
  223. DO 20 I=1,IPT2.NUM(/2)
  224. IP=IPT2.NUM(1,I)
  225. DISMI=123456789.E+10
  226. XA= XCOOR((IP-1)*IDIM1+1)
  227. XB= XCOOR((IP-1)*IDIM1+2)
  228. XC=0.D0
  229. IPMIN=0
  230. IF(IDIM.GT.2)XC=XCOOR((IP-1)*IDIM1+3)
  231. DO 21 J=1,ICPR(/1)
  232. IF(ICPR(J).EQ.0) GO TO 21
  233. YA=XCOOR((J-1)*IDIM1 +1)
  234. YB=XCOOR((J-1)*IDIM1+2)
  235. YC=0.D0
  236. IF(IDIM.GT.2)YC=XCOOR((J-1)*IDIM1+3)
  237. XDI=(YA-XA)*(YA-XA) + (YB-XB)*(YB-XB) + (YC-XC)*(YC-XC)
  238. IF(XDI.LE.DISMI) THEN
  239. DISMI=XDI
  240. IPMIN=J
  241. ENDIF
  242. 21 CONTINUE
  243. C WRITE(6,FMT='( '' POINT INI ET PROCHE '',2I5)') IP,IPMIN
  244. ILOC=ICPR(IPMIN)
  245. INN=INB(ILOC)
  246. IF(INN.GT.LISVO(/1)) THEN
  247. MV=MV+50
  248. SEGSUP ICOO
  249. SEGINI ICOO
  250. ENDIF
  251. LISVO(1)=IPMIN
  252. DO 22 K=1,INN
  253. LISVO(K+1)=IVOI(K,ILOC)
  254. 22 CONTINUE
  255. IDE=INN+1
  256. DO 23 K=1,INN+1
  257. ILOA=ICPR(LISVO(K))
  258. INV=INB(ILOA)
  259. DO 24 L=1,INV
  260. ICAND = IVOI(L,ILOA)
  261. DO 25 M=1,IDE
  262. IF(ICAND.EQ.LISVO(M) ) GO TO 24
  263. 25 CONTINUE
  264. IDE=IDE+1
  265. IF(IDE.GT.MV) THEN
  266. MV=MV+50
  267. SEGADJ ICOO
  268. ENDIF
  269. LISVO(IDE)=ICAND
  270. 24 CONTINUE
  271. 23 CONTINUE
  272. DO 26 K=1,IDE
  273. IGLO= LISVO(K)
  274. X(K)=XCOOR((IGLO-1)*(IDIM+1)+ 1)
  275. Y(K)=XCOOR((IGLO-1)*(IDIM+1)+ 2)
  276. WNODE(K)=W1ND
  277. P(K)=VAL(IGLO)
  278. 26 CONTINUE
  279. DO 27 K=1,INN
  280. 27 WNODE(K) = W1ST
  281. C WRITE(6,FMT= '('' LISTE DES VOISINS '',/,(10I6))')(LISVO(KJI),
  282. C $KJI=1,IDE)
  283. C WRITE(6,FMT= '('' WNODE '',/,(6E12.5))')(WNODE(KIJ),KIJ=1,IDE)
  284. C WRITE(6,FMT= '('' POTENTIEL'',/,(6E12.5))')(P(KIJ),KIJ=1,IDE)
  285. IBON=1
  286. C CALCUL DES PARAMETRES
  287. M42CA = 84
  288. M50CA = 100
  289. IF ( M42.GT.M42CA) THEN
  290. M42=M42CA
  291. IBON=0
  292. ENDIF
  293. IF(M50.GT.M50CA) THEN
  294. M50=M50CA
  295. IBON=0
  296. ENDIF
  297. IF(IBON.EQ.0) THEN
  298. SEGSUP ITRAVA
  299. SEGINI ITRAVA
  300. ENDIF
  301. C APPEL DE LA FONCTION LISSAGE EN SORTIE U,UX,UY,UXX,UXY,UYY SONT
  302. C LES RESULTATS
  303. C
  304. KFLAG= 2
  305. IF ( ICOOR.EQ.1) THEN
  306. C WRITE (ISORT,'(A)') ,'*********** CARTESIEN *************** '
  307. CALL CARSYM (ITYPE,EDICON)
  308. CALL CARWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
  309. *XORG,YORG,IDE,EDICON,ICOO,ITRAVA)
  310. V1= U
  311. V2= UY
  312. V3= - UX
  313. IF (KFLAG.GT. 1) THEN
  314. V4 = UXY
  315. V5 = UYY
  316. V6 = - UXX
  317. V7 = - UXY
  318. END IF
  319. END IF
  320. IF ( ICOOR.EQ.2) THEN
  321. C WRITE (ISORT,'(A)') ,'*********** AXISYMETRIE*************** '
  322. CALL CYLSYM (ITYPE,EDICON)
  323. CALL CYLWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
  324. *IDE,EDICON,ICOO,ITRAVA)
  325. V1 = U
  326. V2 = - UY
  327. V3 = UX
  328. IF (KFLAG.GT. 1) THEN
  329. V4 = - UXY
  330. V5 = - UYY
  331. V6 = UXX
  332. V7 = UXY
  333. END IF
  334. END IF
  335. C
  336. C
  337. C
  338. C
  339. C ON REMPLIT LES VALEURS
  340. C
  341. VPOCHA(I,1)=V1
  342. VPOCHA(I,2)=V2
  343. VPOCHA(I,3)=V3
  344. VPOCHA(I,4)=V4
  345. VPOCHA(I,5)=V5
  346. VPOCHA(I,6)=V6
  347. VPOCHA(I,7)=V7
  348. 20 CONTINUE
  349. SEGDES MPOVAL,IPT2
  350. SEGSUP ICPR,ICOO,IVOISI,IVAL
  351. CALL ECROBJ('CHPOINT ',MCHPO1)
  352. RETURN
  353. END
  354.  
  355.  
  356.  

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