Télécharger lissag.eso

Retour à la liste

Numérotation des lignes :

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

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