Télécharger blocos.eso

Retour à la liste

Numérotation des lignes :

  1. C BLOCOS SOURCE CHAT 06/03/29 21:16:04 5360
  2. C **********************************************************************
  3. C FICHIER : BLOCOS.F
  4. C
  5. C MAILLAGE D'UN DOMAINE DE 4 COTES
  6. C
  7. C OBJET :
  8. C
  9. C OBJET BLOCOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE
  10. C OBJET LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME.
  11. C OBJET Q4CRGR : MAILLAGE EN GRILLE A PARTIR DE 4 COTES
  12. C OBJET (MEME CARDINAUX SUR LES COTES OPPOSES).
  13. C
  14. C
  15. C AUTEUR : O. STAB
  16. C DATE : 06.96
  17. C MODIFICATIONS :
  18. C AUTEUR, DATE, OBJET :
  19. C
  20. C
  21. C **********************************************************************
  22. C
  23. C
  24. SUBROUTINE BLOCOS(IPOLY,N,
  25. > COORD,IDIMC,NBCOOR,
  26. > NBLIG,NBCOL,ICOIN,
  27. > ITVL,NITMAX,
  28. > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
  29. > NBE,NBP,NBEMAX,NBPMAX,
  30. > ICOMPR,ILISS,EPSLIS,W,
  31. > ITRACE,IERCOD,iarr)
  32. C **********************************************************************
  33. C OBJET BLOCOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE
  34. C OBJET LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME.
  35. C
  36. C EN ENTREE :
  37. C ------------- MAILLAGE LINEIQUE ------------
  38. C IPOLY : TABLEAU DES NOEUDS DU CONTOUR FERME
  39. C N : N(I) NOMBRE D'ELEMENTS SUR LE COTES I
  40. C N(I) DOIVENT ETRE STRICTEMENT POSITIF
  41. C LEUR SOMME DOIT ETRE PAIR.
  42. C COORD : TABLEAU DES COORDONNEES DES POINTS
  43. C IDIMC : DIMENSION DE L'ESPACE (>= 2)
  44. C ------------- TABLEAU DE TRAVAIL ------------
  45. C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS
  46. C T1 = 2*(NBCOL+NBLIG) POUR LE CONTOUR
  47. C T2 = (NBCOL*NBLIG) POUR LA GRILLE
  48. C T3 = (NBLIG*NBCOL)*6 POUR LA STRUCTURE
  49. C ITVL >= T1+T3
  50. C NITMAX : TAILLE DE ITVL
  51. C SI NBEMAX = 0 NITMAX PEUT ETRE NUL
  52. C SINON NITMAX >= T1+T3
  53. c
  54. C NBNMAX : NOMBRE DE NOEUDS PAR ELEMENT (>=4)
  55. C NBCMAX : NOMBRE DE VOISINS A UN ELEMENT (>=4)
  56. C ------------- TAILLE DES TABLEAU DE SORTIE ------------
  57. C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS
  58. C SI NBEMAX = 0 LE MAILLAGE N'EST PAS CALCULE
  59. C SEULES LES INFORMATIONS SUR LA GRILLE SONT DONNEES
  60. C SINON NBEMAX >= (NBLIG-1)*(NBCOL-1)
  61. C NBPMAX : NOMBRE MAXIMUM DE POINTS
  62. C NBPMAX >= NBLIG*NBCOL
  63. C
  64. C ITRNOE : TAILLE >= NBEMAX*NBNMAX
  65. C ITRTRI : TAILLE >= NBEMAX*NBCMAX
  66. C NOETRI : TAILLE >= NBPMAX
  67. C COORD : TAILLE >= NBPMAX*IDIMC
  68. C
  69. C ------------- PARAMETRES DE POSTTRAITEMENT ------------
  70. C ICOMPR : ICOMPR = 1, COMPRESSION ACTIVE
  71. C ILISS : LISSAGE DES NOEUDS INTERIEURS ACTIF
  72. C EPSLIS : DEPLACEMENT NEGLIGEABLE
  73. C W : COEFFICIENT DE RIGIDITE DES ELEMENTS QUADRANGULAIRES
  74. C [0,1] (LISSAGE DE HERRMANN)
  75. C
  76. C EN SORTIE :
  77. C ------------- INFORMATIONS SUR LA GRILLE -----------
  78. C NBLIG, NBCOL, ICOIN : NOMBRE DE LIGNE ET NOMBRE DE COLONNES DE
  79. C LA GRILLE AVEC LES VALEURS DES COUPER-COLLER AUX COINS.
  80. C ------------- LE MAILLAGE --------------------------
  81. C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBE,NBP : LE MAILLAGE
  82. C EN QUADRANGLES LINEAIRES
  83. C COORD : TABLEAU DES COORDONNEES DES POINTS (COMPLETE)
  84. C iarr : TYPE D'ERREUR
  85. C -1 SI DONNEES INCORRECTES
  86. C -2 SI TABLEAUX INSUFFISANTS(COORD,ITRNOE OU ITVL)
  87. C IERCOD : CODE DETAILLE DE L'ERREUR
  88. C -100 : ERREUR NON REPERTORIEE
  89. C -101 : LE NOMBRE DE NOEUDS SUR LE CONTOUR EST IMPAIR
  90. C -102 : LA DIMENSION DES COORDONNEES EST INCORRECTE
  91. C -103 : LE CONTOUR N A PAS 4 COTES
  92. C APPELS : Q4CRGR
  93. C **********************************************************************
  94. IMPLICIT INTEGER(I-N)
  95. INTEGER IPOLY(*),N(*)
  96. REAL*8 COORD(*)
  97. INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX
  98. INTEGER NBLIG,NBCOL,ICOIN(*)
  99. INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX
  100. INTEGER NBEMAX,NBPMAX,NBE,NBP
  101. INTEGER ICOMPR,ILISS
  102. REAL*8 EPSLIS,W
  103. INTEGER ITRACE,IERCOD,iarr
  104. C
  105. C --- VARIABLES INTERNES ---
  106. INTEGER I,ICOURF,IND(4),NBEL2
  107. C
  108. INTEGER INDICE,INCREM
  109. INTEGER NBCOAJ(2),INCOAJ(2),NBAJ
  110. INTEGER INDXYZ,ITRAV,NITMX2
  111. INTEGER ITBLOQ,IPARA,NPASMX,NCC,NBENUL,NBISOL
  112. REAL*8 RELAX,RTRAV(3)
  113. C =============================
  114. C --- 0. VERIFICATION DES ENTREES ---
  115. C =============================
  116. IERCOD = -100
  117. NBE = 0
  118. NBP = 0
  119. NBLIG = 0
  120. NBCOL = 0
  121. DO 5 I=1,4
  122. ICOIN(I) = 0
  123. 5 CONTINUE
  124. C
  125. IF( (N(1).LT.1).OR.(N(2).LT.1).OR.
  126. > (N(3).LT.1).OR.(N(4).LT.1))THEN
  127. IERCOD = -103
  128. iarr = -1
  129. GOTO 9999
  130. ENDIF
  131. IF( MOD(N(1)+N(2)+N(3)+N(4),2) .NE.0 )THEN
  132. IERCOD = -101
  133. iarr = -1
  134. GOTO 9999
  135. ENDIF
  136. IF( IDIMC.LT.0 )THEN
  137. IERCOD = -102
  138. iarr = -1
  139. GOTO 9999
  140. ENDIF
  141. C
  142. C ===========================
  143. C --- 0. ON DETERMINE LA MEMOIRE ---
  144. C ===========================
  145. C
  146. CALL G2NBKK(N(1),N(2),N(3),N(4),
  147. > ICOIN(1),ICOIN(2),ICOIN(3),ICOIN(4),iarr)
  148. IF( iarr.NE. 0 )GOTO 9999
  149. C
  150. NBLIG = MAX(N(4)+ICOIN(4)+ICOIN(3),N(2)+ICOIN(2)+ICOIN(1)) + 1
  151. NBCOL = MAX(ICOIN(4)+N(1)+ICOIN(1),ICOIN(2)+N(3)+ICOIN(3)) + 1
  152. NBE = (NBLIG-1)*(NBCOL-1)
  153. NBP = NBCOL*NBLIG
  154. C
  155. IF(NBEMAX.EQ.0)GOTO 9999
  156. C
  157. IF(NBEMAX.LT.NBE)THEN
  158. iarr = -2
  159. CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ')
  160. CALL ESEINT(1,'PLACE NECESSAIRE POUR LES ELEMENTS',NBE*NBNMAX,1)
  161. GOTO 9999
  162. ENDIF
  163. IF(NBPMAX.LT.NBP)THEN
  164. iarr = -2
  165. CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ')
  166. CALL ESEINT(1,'PLACE NECESSAIRE POUR LES NOEUDS',NBP*IDIMC,1)
  167. GOTO 9999
  168. ENDIF
  169. IF(NITMAX.LT.(2*(NBCOL+NBLIG)+(NBCOL*NBLIG)))THEN
  170. iarr = -2
  171. CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ')
  172. CALL ESEINT(1,'PLACE NECESSAIRE POUR LES CALCUL',
  173. > (2*(NBCOL+NBLIG)+(NBCOL*NBLIG)),1)
  174. ENDIF
  175. C
  176. C ===========================
  177. C --- 1. ON COMPLETE LES COURBES ---
  178. C ===========================
  179. C
  180. IF(ITRACE.GT.0)
  181. > CALL ESECHA(1,'-> COURBES COMPLETEES',' ')
  182. C
  183. C
  184. C --- CONSTRUCTION D'UN MAILLAGE DE FRONTIERE SIMPLE :
  185. C DE 4 COTES (NBLIG,NBCOL,NBLIG,NBCOL)
  186. C NOEUDS RESPECTIVEMENT
  187. C --- INDICE DES NOEUDS DES COTES ---
  188. IND(1) = N(1) + 1
  189. DO 10 I=2,4
  190. IND(I) = N(I) + IND(I-1)
  191. 10 CONTINUE
  192. ICOURF = 1
  193. C
  194. INDXYZ = NBCOOR+1
  195. INDICE = NBCOOR+1
  196. INCREM = 1
  197. C
  198. NBAJ = 2
  199. INCOAJ(1) = 1
  200. NBCOAJ(1) = ICOIN(4)
  201. NBCOAJ(2) = ICOIN(1)
  202. INCOAJ(2) = -N(1)-1
  203. CALL G2MOCO(IPOLY,1,N(1)+1,
  204. > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
  205. > ITVL(ICOURF),NBLIG2,NBEL2)
  206. C PRINT *,'N1 = ',NBEL2
  207. C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
  208. CALL G2POCO(IPOLY,1,N(1)+1,
  209. > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
  210. > COORD,IDIMC)
  211. C
  212. INCOAJ(1) = 1
  213. NBCOAJ(1) = ICOIN(1)
  214. NBCOAJ(2) = ICOIN(2)
  215. INCOAJ(2) = -N(2)-1
  216. C PRINT *,' IND =',ICOURF+NBCOL-1
  217. CALL G2MOCO(IPOLY(IND(1)),1,N(2)+1,
  218. > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
  219. > ITVL(ICOURF+NBCOL),NBLIG2,NBEL2)
  220. CALL G2POCO(IPOLY(IND(1)),1,N(2)+1,
  221. > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
  222. > COORD,IDIMC)
  223. C PRINT *,'N2 = ',NBEL2
  224. C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
  225. C
  226. INCOAJ(1) = 1
  227. NBCOAJ(1) = ICOIN(2)
  228. NBCOAJ(2) = ICOIN(3)
  229. INCOAJ(2) = -N(3)-1
  230. C PRINT *,' IND =',ICOURF+NBCOL+NBLIG-1
  231. CALL G2MOCO(IPOLY(IND(2)),1,N(3)+1,
  232. > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
  233. > ITVL(ICOURF+NBCOL+NBLIG),NBLIG2,NBEL2)
  234. CALL G2POCO(IPOLY(IND(2)),1,N(3)+1,
  235. > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
  236. > COORD,IDIMC)
  237. C PRINT *,'N3 = ',NBEL2
  238. C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
  239. C
  240. INCOAJ(1) = 1
  241. NBCOAJ(1) = ICOIN(3)
  242. NBCOAJ(2) = ICOIN(4)
  243. INCOAJ(2) = -N(4)-1
  244. C PRINT *,' IND =',ICOURF+2*NBCOL+NBLIG-1
  245. CALL G2MOCO(IPOLY(IND(3)),1,N(4)+1,
  246. > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
  247. > ITVL(ICOURF+2*NBCOL+NBLIG),NBLIG2,NBEL2)
  248. CALL G2POCO(IPOLY(IND(3)),1,N(4)+1,
  249. > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
  250. > COORD,IDIMC)
  251. C
  252. C PRINT *,'N4 = ',NBEL2
  253. C PRINT *,'IPOLY = ',(IPOLY(I),I=1,N(1)+N(2)+N(3)+N(4))
  254. C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
  255. C PRINT *,((COORD((I-1)*IDIMC+J),J=1,IDIMC),'+',I=1,INDXYZ)
  256. C PRINT *,'ITRACE =',ITRACE
  257. C
  258. C ========================================
  259. C --- 2.CREATION DU PAVAGE ---
  260. C ========================================
  261. C
  262. C
  263. IF(ITRACE.GT.0)
  264. > CALL ESECHA(1,'-> CREATION DU PAVAGE',' ')
  265. C
  266. ITRAV = ICOURF + 2*(NBLIG+NBCOL)
  267. NITMX2 = NITMAX - ITRAV
  268. NBCOOR = INDXYZ - 1
  269. C ------- POUR LE TEST SANS COLLAGE ---
  270. C DO 20 I=1,4
  271. C ICOIN(I) = 0
  272. C 20 CONTINUE
  273. CALL Q4CRGR(ITVL(ICOURF),ITVL(NBCOL+ICOURF),
  274. > ITVL(ICOURF+NBCOL+NBLIG),
  275. > ITVL(ICOURF+2*NBCOL+NBLIG),N,
  276. > COORD,IDIMC,NBCOOR,
  277. > NBLIG,NBCOL,ICOIN,
  278. > ITVL(ITRAV),NITMX2,
  279. > IDE,ITRNOE,NBNMAX,NBE,NBP,
  280. > NBEMAX,NBPMAX,ITRACE,iarr)
  281. C
  282. IF(iarr.NE.0)THEN
  283. CALL DSERRE(1,iarr,'BLOCOS',' APPEL Q4CRGR ')
  284. GOTO 9999
  285. ENDIF
  286. C
  287. C ===================================================
  288. C --- 3. COMPRESSION DU MAILLAGE ---
  289. C ===================================================
  290. C
  291. IDE = 2
  292. C
  293. IF(( (ICOIN(1)+ICOIN(2)+ICOIN(3)+ICOIN(4)).NE.0).AND.
  294. > (ICOMPR.EQ.1))THEN
  295. C
  296. IF(ITRACE.GT.0)
  297. > CALL ESECHA(1,'-> COMPRESSION DU MAILLAGE',' ')
  298. C
  299. NBENUL = NBE
  300. NBISOL = NBP
  301. CALL NUGCNU(IDE,ITRNOE,NBNMAX,0,0,
  302. > 0,0,NBE,COORD,IDIMC,NBP,
  303. > ITVL,NITMAX,iarr)
  304. C
  305. IF(iarr.NE.0)THEN
  306. CALL DSERRE(1,iarr,'BLOCOS',' APPEL NUGCNU ')
  307. GOTO 9999
  308. ENDIF
  309. C
  310. IF(ITRACE.GT.0)THEN
  311. CALL ESEINT(1,'NOMBRE D ELEMENTS SUPPRIMES : ',NBENUL-NBE,1)
  312. CALL ESEINT(1,'NOMBRE DE POINTS SUPPRIMES : ',NBISOL-NBP,1)
  313. ENDIF
  314. ENDIF
  315. C
  316. C ============================================
  317. C --- 4.CREATION DE LA STRUCTURE DE DONNEES ---
  318. C ============================================
  319. C
  320. IF(ITRACE.GT.0)
  321. > CALL ESECHA(1,'-> CREATION DE LA STRUCTURE',' ')
  322. C
  323. CALL SMAOCR(IDE,ITRNOE,NBE,COORD,NBP,IDIMC,
  324. > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
  325. > ITVL,NITMAX,NCC,iarr)
  326. C
  327. IF(iarr.NE.0)THEN
  328. CALL DSERRE(1,iarr,'BLOCOS',' APPEL SMAOCR ')
  329. GOTO 9999
  330. ENDIF
  331. C
  332. C ============================================
  333. C --- 5.LISSAGE (BARYCENTRIQUE,ISOPARAMETRIQUE) ---
  334. C ============================================
  335. C
  336. IF( ILISS.EQ. 1)THEN
  337. C
  338. IF(ITRACE.GT.0)
  339. > CALL ESECHA(1,'-> LISSAGE',' ')
  340. C
  341. C WRITE(6,*) 'ITRTRI = ',((ITRTRI((I-1)*NBCMAX+J),J=1,NBCMAX),
  342. C > '/',I=1,NBE)
  343. C WRITE(6,*) 'NOETRI = ',(NOETRI(I),I=1,NBN)
  344. ITBLOQ = 1
  345. IPARA = 0
  346. RELAX = 1.5
  347. NPASMX = 100
  348. * CALL LISNOI(ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBP,
  349. * > COORD,IDIMC,
  350. * > COORD,IDIMC,EPSLIS,COORD,
  351. * > ITBLOQ,0,0,
  352. * > IPARA,RELAX,NPASMX,
  353. * > W,RTRAV,ITRACE,iarr)
  354. C
  355. IF(iarr.NE.0)THEN
  356. CALL DSERRE(1,iarr,'BLOCOS',' APPEL LISNOI ')
  357. GOTO 9999
  358. ENDIF
  359. ENDIF
  360. C
  361. 9999 END
  362.  
  363.  
  364.  
  365.  
  366.  

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