Télécharger nloca1.eso

Retour à la liste

Numérotation des lignes :

  1. C NLOCA1 SOURCE CHAT 11/03/16 21:28:35 6902
  2. SUBROUTINE NLOCA1(IPCHI,IPLMOT,IPCHCO, IPCHO, IRET)
  3. C_______________________________________________________________________
  4. C
  5. C CALCUL DE LA MOYENNE NONLOCALE
  6. C
  7. C
  8. C Entrees:
  9. C ________
  10. C
  11. C IPCHI Pointeur sur un MCHAML de ss-type indifferent
  12. C IPLMOT Pointeur sur un LISTMOTS de noms de composante
  13. C
  14. C IPCHCO Pointeur sur un MCHAML de Connectivite
  15. C (ss-type CONNECTIVITE NON LOCAL)
  16. C
  17. C Sorties:
  18. C ________
  19. C
  20. C IPCHO Pointeur sur un MCHAML de meme ss-type que IPCHI
  21. C avec les composantes IPLMOT moyennees
  22. C les composantes non reconnues dans iplmot sont
  23. C recopiees
  24. C
  25. C IRET 1 ou 0 suivant succes ou pas
  26. C
  27. C
  28. C Appele par: NLOCAL
  29. C -----------
  30. C
  31. C Appel a:
  32. C --------
  33. C
  34. C NLOVEP verification et preparation de la moyenne
  35. C TRTRVE point translate
  36. C TRSYPT point symetrique par rapport a un point
  37. C TRSYDR point symetrique par rapport a une droite
  38. C TRSYPL point symetrique par rapport a un plan
  39. C DOXE, JACOBI
  40. C
  41. C P.PEGON OCTOBRE 92 D'APRES C. LA BORDERIE AVRIL 1992 D'APRES P. PEGON
  42. C_______________________________________________________________________
  43. C
  44. IMPLICIT INTEGER(I-N)
  45. IMPLICIT REAL*8(A-H,O-Z)
  46. *
  47. -INC SMMODEL
  48. -INC CCOPTIO
  49. -INC SMELEME
  50. -INC SMCOORD
  51. -INC SMCHAML
  52. -INC SMLENTI
  53. -INC SMLREEL
  54. -INC SMLMOTS
  55. -INC SMINTE
  56. **
  57. * SEGMENT INFO
  58. * INTEGER INFELE(JG)
  59. * ENDSEGMENT
  60. *
  61. SEGMENT,WRK1
  62. REAL*8 XE(3,NBNN)
  63. ENDSEGMENT
  64. *
  65. SEGMENT NLOC1
  66. INTEGER ILOC2 (NZONEF)
  67. END SEGMENT
  68. *
  69. SEGMENT NLOC2
  70. INTEGER MPCHAM (NDOUBL)
  71. INTEGER ILOC4 (NDOUBL)
  72. INTEGER MODLAC,MAILEF,MINTEF
  73. INTEGER MAILAC (NSZACC)
  74. INTEGER MINTAC (NSZACC)
  75. INTEGER ILOC3 (NSZACC)
  76. INTEGER ILOC3I,ILOC3O
  77. INTEGER MELCAR
  78. END SEGMENT
  79. *
  80. SEGMENT NLOC3
  81. INTEGER MELVAC (NCOMP)
  82. END SEGMENT
  83. *
  84. SEGMENT NLOC4
  85. INTEGER JCLE
  86. REAL*8 PT1(3),PT2(3),DISP
  87. INTEGER MELPNI,MELPLI
  88. END SEGMENT
  89. *
  90. SEGMENT,WRK2
  91. REAL*8 XEJ(3,NBNJ),SHP(6,NBNJ)
  92. ENDSEGMENT
  93. *
  94. SEGMENT WRK3
  95. REAL*8 SOMCOM(NCOMP,NBPGAU)
  96. REAL*8 SOMJAC( NBPGAU)
  97. END SEGMENT
  98. *
  99. POINTEUR MLCOMP.MLENTI
  100. POINTEUR MLNIMO.MLENTI
  101. *
  102. C
  103. DIMENSION XXX(3),XXXJ(3)
  104. C+PP
  105. DATA XMULTL/1.5/
  106. C+PP
  107. NHRM=NIFOUR
  108. IRET=1
  109. C
  110. C ON VERIFIE/PREPARE LES DONNEES
  111. C
  112. CALL NLOVEP(IPCHCO,IPCHI,IPLMOT, IPCHO,NLOC1, IRET)
  113. IF (IRET.EQ.0)RETURN
  114. C
  115. C ON TRAITE L'INFORMATION
  116. C
  117. C BOUCLE SUR LES ZONES EFFECTIVES
  118. C
  119. NZONEF=ILOC2(/1)
  120. DO ISOUCF=1,NZONEF
  121. C write(IOIMP,*)'ZONE EFFECTIVE',ISOUCF
  122. NLOC2=ILOC2(ISOUCF)
  123. MINTE1=MINTEF
  124. IPT1=MAILEF
  125. NDOUBL=ILOC4(/1)
  126. NLOC3=ILOC3I
  127. NCOMP=MELVAC(/1)
  128. C
  129. C NOMBRE DE POINTS DE GAUSS PAR ELEMENTS POUR LA SS ZONE A MOYENNER
  130. C
  131. NBPGAU=MINTE1.POIGAU(/1)
  132. C
  133. C NOMBRE D'ELEMENTS ET DE NOEUDS POUR LA SS ZONE A MOYENNER
  134. C
  135. NBELEM=IPT1.NUM(/2)
  136. NBNN =IPT1.NUM(/1)
  137. SEGINI WRK1
  138. SEGINI WRK3
  139. C
  140. C DEBUT DE LA BOUCLE SUR LES ELEMENTS
  141. C
  142. DO IB=1,NBELEM
  143. C write(IOIMP,*)' ELEMENT NUMERO',IB
  144. C
  145. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  146. C
  147. CALL DOXE(XCOOR,IDIM,NBNN,IPT1.NUM,IB,XE)
  148. C
  149. C INITIALISATION DES DIVERSES INTEGRATIONS
  150. C
  151. DO IGAU=1,NBPGAU
  152. SOMJAC(IGAU)=0.D0
  153. DO IE1=1,NCOMP
  154. SOMCOM(IE1,IGAU)=0.D0
  155. END DO
  156. END DO
  157. C
  158. C ON BOUCLE SUR LES DOUBLONS
  159. C
  160. DO IDOUBL=1,NDOUBL
  161. NLOC4=ILOC4(IDOUBL)
  162. ICLE=JCLE
  163. C
  164. C ON RECUPERE LE NUMERO D'ORDRE DES SOUS ZONES ACCESSIBLES
  165. C
  166. MELVAL=MELPNI
  167. MLNIMO=IELCHE(1,IB)
  168. C write(IOIMP,*)' DOUBLON ICLE MLNIMO ',IDOUBL,ICLE,MLNIMO
  169. C
  170. C CET ELEMENT EST IL EN CONNECTIVITE ?
  171. C
  172. IF (MLNIMO.NE.0)THEN
  173. SEGACT,MLNIMO
  174. C
  175. C ON RECUPERE LA LISTE DES ELEMENTS ACCESSIBLES DANS
  176. C LE CHAMELEM DE CONNECTIVITE
  177. C
  178. MELVAL=MELPLI
  179. MLENTI=IELCHE(1,IB)
  180. SEGACT,MLENTI
  181. C
  182. C ON CREE UN MLENT1 QUI PERMETTRA DE TROUVER LE DEBUT DE L'INFORMATION
  183. C CONCERNANT CHAQUE SS ZONE
  184. C
  185. JG=1
  186. SEGINI MLENT1
  187. MLENT1.LECT(1)=1
  188. NSOUSA=MLNIMO.LECT(/1)
  189. IF (NSOUSA.GT.1)THEN
  190. DO IISOUJ=2,NSOUSA
  191. JG=MLENT1.LECT(/1)+1
  192. SEGADJ MLENT1
  193. MLENT1.LECT(JG)=MLENT1.LECT(JG-1)+
  194. 1 LECT(MLENT1.LECT(JG-1))+1
  195. END DO
  196. ENDIF
  197. C
  198. C DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION
  199. C
  200. DO IGAU=1,NBPGAU
  201. C
  202. C ON RECUPERE LA LONGUEUR CARACTERISTIQUE
  203. C
  204. MELVAL=MELCAR
  205. XLONG=VELCHE(MIN(IGAU,VELCHE(/1)),MIN(IB,VELCHE(/2)))
  206. C write(IOIMP,*)' GAUSS-P,XLONG ',IGAU,XLONG
  207. C
  208. C ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION
  209. C
  210. DO IE1=1,3
  211. XXX(IE1)=0.D0
  212. DO IE2=1,NBNN
  213. CGAUSS=MINTE1.SHPTOT(1,IE2,IGAU)
  214. XXX(IE1)=XXX(IE1)+XE(IE1,IE2)*CGAUSS
  215. END DO
  216. END DO
  217. C write(IOIMP,*)' XXX ',XXX
  218. C
  219. C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES
  220. C
  221. DO IISOUJ=1,NSOUSA
  222. IISOUS=MLNIMO.LECT(IISOUJ)
  223. NLOC3=ILOC3(IISOUS)
  224. IPT2=MAILAC(IISOUS)
  225. MINTE2=MINTAC(IISOUS)
  226. C
  227. NBPGAJ=MINTE2.POIGAU(/1)
  228. NBNJ =IPT2.NUM(/1)
  229. C
  230. IG1=MLENT1.LECT(IISOUJ)
  231. NBELEJ=LECT(IG1)
  232. C write(IOIMP,*)' ZONES-AC,IISOUS ',IISOUJ,IISOUS
  233. C
  234. C DEBUT DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES
  235. C
  236. SEGINI,WRK2
  237. DO IIBJ=1,NBELEJ
  238. IG1=IG1+1
  239. IBJ=LECT(IG1)
  240. C write(IOIMP,*)' ELEMENT_AC ',IBJ
  241. C
  242. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IIBJ
  243. C
  244. CALL DOXE(XCOOR,IDIM,NBNJ,IPT2.NUM,IBJ,XEJ)
  245. C
  246. C DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION
  247. C
  248. DO IGAUJ=1,NBPGAJ
  249. C
  250. C ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION
  251. C
  252. DO IE1=1,3
  253. XXXJ(IE1)=0.D0
  254. DO IE2=1,NBNJ
  255. CGAUSS=MINTE2.SHPTOT(1,IE2,IGAUJ)
  256. XXXJ(IE1)=XXXJ(IE1)+XEJ(IE1,IE2)*CGAUSS
  257. END DO
  258. END DO
  259. C write(IOIMP,*)' GAUSS-AC ',IGAUJ
  260. C write(IOIMP,*)' XXXJ-AS ',XXXJ
  261. C
  262. C ON TRANSFORME CES COORDONNEES EN FONCTION DES SYMETRIE OU DE LA
  263. C TRANSLATION
  264. C
  265. IF(ICLE.EQ.2)CALL TRTRVE(XXXJ,1,PT1 )
  266. IF(ICLE.EQ.3)CALL TRSYPT(XXXJ,1,PT1 )
  267. IF(ICLE.EQ.4)CALL TRSYDR(XXXJ,1,PT1,PT2 )
  268. IF(ICLE.EQ.5)CALL TRSYPL(XXXJ,1,PT1,DISP)
  269. C write(IOIMP,*)' XXXJ-PS ',XXXJ
  270. C
  271. C ON REMPLIT LES SHP
  272. C
  273. DO IE1=1,6
  274. DO IE2=1,NBNJ
  275. SHP(IE1,IE2)=MINTE2.SHPTOT(IE1,IE2,IGAUJ)
  276. END DO
  277. END DO
  278. C
  279. C ON CALCULE LE JACOBIEN
  280. C
  281. CALL JACOBI(XEJ,SHP,IDIM,NBNJ,DJAC)
  282. C
  283. C ON CALCULE LA VALEUR DE LA GAUSSIENNE
  284. C
  285. XXLONG=(XXX(1)-XXXJ(1))**2+(XXX(2)-XXXJ(2))**2+
  286. 1 (XXX(3)-XXXJ(3))**2
  287. XXLONG=SQRT(XXLONG)
  288. C write(IOIMP,*)' XXLONG,DJAC ',XXLONG,DJAC
  289. IF(XXLONG.LE.XMULTL*XLONG)THEN
  290. GDEX=EXP(-(2*XXLONG/XLONG)**2)
  291. DJAC=MINTE2.POIGAU(IGAUJ)*GDEX*ABS(DJAC)
  292. DO IE1=1,NCOMP
  293. MELVAL=MELVAC(IE1)
  294. C
  295. C ON DOIT RETROUVER LE NUMERO D'ELEMENT ATTACHE AU CHAMELEM
  296. C CORRESPONDANT A CELUI DU MELEME
  297. C
  298. IBMN=MIN(IBJ ,VELCHE(/2))
  299. IGMN=MIN(IGAUJ,VELCHE(/1))
  300. SOMCOM(IE1,IGAU)=SOMCOM(IE1,IGAU)
  301. 1 +VELCHE(IGMN,IBMN)*DJAC
  302. C write(IOIMP,*)' VELCHE,DJAC ',VELCHE(IGMN,IBMN),DJAC
  303. END DO
  304. SOMJAC(IGAU)=SOMJAC(IGAU)+DJAC
  305. ENDIF
  306. C
  307. C FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION
  308. C
  309. END DO
  310. C
  311. C FIN DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES
  312. C
  313. END DO
  314. C
  315. SEGSUP,WRK2
  316. C
  317. C FIN DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES
  318. C
  319. END DO
  320. C
  321. C FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION
  322. C
  323. END DO
  324. SEGDES MLENTI
  325. SEGDES MLNIMO
  326. SEGSUP MLENT1
  327. C
  328. C FIN DU TEST D'EXISTENCE DE CONNECTIVITE SUR L'ELEMENT
  329. C
  330. ENDIF
  331. C
  332. C FIN DE LA BOUCLE SUR LES DOUBLONS
  333. C
  334. END DO
  335. C
  336. NLOC3=ILOC3O
  337. DO IGAU=1,NBPGAU
  338. DO IE1=1,NCOMP
  339. MELVAL=MELVAC(IE1)
  340. SEGACT MELVAL*MOD
  341. VELCHE(IGAU,IB)=SOMCOM(IE1,IGAU)/SOMJAC(IGAU)
  342. END DO
  343. END DO
  344. C
  345. C FIN DE LA BOUCLE SUR LES ELEMENTS
  346. C
  347. END DO
  348. SEGSUP WRK1
  349. SEGSUP WRK3
  350. C
  351. C FIN DE LA BOUCLE SUR LES SOUS ZONES EFFECTIVES
  352. C
  353. END DO
  354. C
  355. C DESACTIVATIONS/SUPRESSION
  356. C WARNING SUR LES DOUBLONS DE MODEL!
  357. C
  358. DO IZONEF=1,NZONEF
  359. NLOC2=ILOC2(IZONEF)
  360. NDOUBL=ILOC4(/1)
  361. DO IDOUBL=1,NDOUBL
  362. NLOC4=ILOC4(IDOUBL)
  363. MELVAL=MELPNI
  364. SEGDES,MELVAL
  365. MELVAL=MELPLI
  366. SEGDES,MELVAL
  367. SEGSUP,NLOC4
  368. ENDDO
  369. NSZACC=ILOC3(/1)
  370. DO ISZACC=1,NSZACC
  371. NLOC3=ILOC3(ISZACC)
  372. SEGSUP,NLOC3
  373. ENDDO
  374. NLOC3=ILOC3I
  375. NCOMP=MELVAC(/1)
  376. DO ICOMP=1,NCOMP
  377. MELVAL=MELVAC(ICOMP)
  378. SEGDES,MELVAL
  379. ENDDO
  380. SEGSUP,NLOC3
  381. NLOC3=ILOC3O
  382. NCOMP=MELVAC(/1)
  383. DO ICOMP=1,NCOMP
  384. MELVAL=MELVAC(ICOMP)
  385. SEGDES,MELVAL
  386. ENDDO
  387. SEGSUP,NLOC3
  388. MMODEL=MODLAC
  389. DO ISZACC=1,NSZACC
  390. MINTE=MINTAC(ISZACC)
  391. SEGDES,MINTE
  392. IMODEL=KMODEL(ISZACC)
  393. SEGDES,IMODEL
  394. ENDDO
  395. MELEME=MAILEF
  396. SEGDES,MELEME
  397. ENDDO
  398. DO IZONEF=1,NZONEF
  399. NLOC2=ILOC2(IZONEF)
  400. MMODEL=MODLAC
  401. SEGDES,MMODEL
  402. SEGSUP,NLOC2
  403. ENDDO
  404. SEGSUP,NLOC1
  405. C
  406. C BYE BYE
  407. C
  408. RETURN
  409. END
  410.  
  411.  
  412.  
  413.  
  414.  
  415.  
  416.  
  417.  
  418.  
  419.  
  420.  
  421.  

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