Télécharger raft.eso

Retour à la liste

Numérotation des lignes :

raft
  1. C RAFT SOURCE PV 22/04/19 21:15:04 11344
  2. SUBROUTINE RAFT
  3. C **********************************************************************
  4. C INTERFACE CASTEM 2000
  5. C
  6. C SURF2 = RAFT (CHPO1) SURF1 ;
  7. C
  8. C
  9. C OBJET :
  10. C _______
  11. C
  12. C L'OPERATEUR RAFT RAFINE UN MAILLAGE TRIANGULAIRE (OBJET SURF1)
  13. C POUR RESPECTER UNE CARTE DE TAILLEW DONNEE (OBJET CHPO1). LES ELEM-
  14. C ENTS SONT DES TRIANGLES LINEAIRES QUELLES QUE SOIENT LES DIRECTIVES
  15. C D'OPTION.
  16. C
  17. C
  18. C DATE : 03.05.96 / 03.04.97
  19. C ______
  20. C
  21. C AUTEURS : O. STAB
  22. C _________
  23. C
  24. C
  25. C **********************************************************************
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8 (A-H,O-Z)
  28. C
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMELEME
  33. -INC SMCOORD
  34. -INC CCGEOME
  35. -INC SMCHPOI
  36. SEGMENT ITRAVX
  37. INTEGER ITVL (ITOTAI)
  38. ENDSEGMENT
  39. SEGMENT RTRAV
  40. REAL*8 RTVL ( ITOTAR)
  41. ENDSEGMENT
  42. SEGMENT ICPR (nbpts)
  43. SEGMENT ICPP (nbpts)
  44. SEGMENT IRADEC
  45. REAL*8 RADEC (MRIADEC)
  46. ENDSEGMENT
  47. DIMENSION IADEC(1)
  48. C elimination de l'external TC
  49. C INTEGER D2CHPO
  50. C EXTERNAL D2CHPO
  51. INTEGER NRIADC,NITMAX,NRTMAX,NPONEW,IERRDS
  52. C --- VARIABLES INTERNES ---
  53. INTEGER NBN,NBE,IDIMC,NBNMAX,NBCMAX,IDE,NPOMAX,NBEMAX,ITRNOE
  54. INTEGER ITRTRI,NOETRI,ITRAV,IRTRAV,NITMX2,NRTMX2,ICOORD
  55. INTEGER I,NCC,NOEMAX
  56. C
  57. CALL DSINIT
  58. IERRDS = 0
  59. C =======================
  60. C --- 1.LECTURE DES DONNEES ---
  61. C =======================
  62. C
  63. * LECTURE DES OBJETS COURANTS (ENTREES)
  64. * =====================================
  65. IF(IDIM.NE.2) THEN
  66. INTERR(1)=IDIM
  67. C FONCTION INDISPONIBLE EN DIMENSION %I1
  68. CALL ERREUR(709)
  69. GOTO 999
  70. ENDIF
  71. C
  72. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  73. IF(IERR.NE.0) THEN
  74. C ON A PAS TROUVE LE MAILLAGE
  75. CALL ERREUR(503)
  76. GOTO 999
  77. ENDIF
  78. C
  79. CALL LIRENT ( IVAL,0,IRETOU)
  80. C
  81. SEGACT IPT1
  82. NBE = IPT1.NUM(/2)
  83. NBEINI = NBE
  84. NBNTOT = -1
  85. IF(IRETOU.NE.0) THEN
  86. IF( IVAL.LT.NBE )THEN
  87. C Le nombre de noeuds ne peut ètre inférieur à %i1
  88. C (nombre d'éléments)
  89. INTERR(1) = NBE
  90. CALL ERREUR(838)
  91. SEGDES IPT1
  92. GOTO 999
  93. ENDIF
  94. NBNTOT = IVAL
  95. ENDIF
  96.  
  97. IF((IPT1.LISOUS(/1).NE.0).OR.
  98. > (IPT1.ITYPEL.NE.4))THEN
  99. C DONNEES INCOMPATIBLES
  100. CALL ERREUR(21)
  101. SEGDES IPT1
  102. GOTO 999
  103. ENDIF
  104. SEGDES IPT1
  105. *
  106. * LECTURE DU CHAMPS DE DENSITE
  107. * ============================
  108. *
  109. CALL LIROBJ('CHPOINT',MCHPO1,0,IRETOU)
  110. IF(IRETOU.EQ.0)THEN
  111. C ON A PAS TROUVE LE CHAMPS DE POINTS
  112. IF(IIMPI.NE.0) CALL ERREUR(839)
  113. PCHPOI = 0
  114. ELSE
  115. PCHPOI = 1
  116. ENDIF
  117. C
  118. C ---- VERIFICATION DU CHPOINT ----
  119. IF( PCHPOI.EQ.1)THEN
  120. SEGACT MCHPO1
  121. MSOUP1 = MCHPO1.IPCHP(1)
  122. SEGACT MSOUP1
  123. IF( MCHPO1.IPCHP(/1).GT.1)THEN
  124. C IL Y A PLUS D'UN CHAMP PAR POINT LEQUEL CHOISIR ?
  125. CALL ERREUR(840)
  126. SEGDES IPT1,MCHPO1,MSOUP1
  127. GOTO 999
  128. ENDIF
  129. C
  130. 8003 MPOVA1 = MSOUP1.IPOVAL
  131. SEGACT MPOVA1
  132. IF( MPOVA1.VPOCHA(/2).NE.1 )THEN
  133. C Il y a plus d'une valeur par point ?!
  134. CALL ERREUR(841)
  135. SEGDES IPT1,MCHPO1,MSOUP1,MPOVA1
  136. GOTO 999
  137. ENDIF
  138. SEGDES MCHPO1,MSOUP1,MPOVA1
  139. ENDIF
  140. C ---- FIN VERIFICATION DU CHPOINT ----
  141. *
  142. *
  143. * ALLOCATION DE LA MEMOIRE
  144. * =====================================
  145. *
  146. *
  147. *
  148. * =====================================
  149. IDIMC = IDIM
  150. NBNMAX = 3
  151. NBCMAX = NBNMAX
  152. NBADET = 50
  153. C
  154. ICMEMO = 1
  155. NBNINI = 0
  156. C
  157. C --- POUR TESTER LES MESSAGE D'ERREUR ET LA REALLOCATION :
  158. NBNREL = (10 * NBEINI ) / 2
  159. NBNABS = 40000
  160. 5 CONTINUE
  161. NBNREL = 7 * (NBEINI / 2)
  162. IF( NBNINI.NE.0 )NBNREL = 7 * NBNINI
  163. IF(NBNTOT.NE.-1) THEN
  164. NPOMAX = NBNTOT*ICMEMO + NBADET
  165. ELSE
  166. NPOMAX = MAX(NBNREL,NBNABS)*ICMEMO + NBADET
  167. ENDIF
  168. NBEMAX = MAX((14*NBEINI),(2*NBNABS)) * ICMEMO
  169. C
  170. 6 CONTINUE
  171. C
  172. C NITMAX = 20 * NPOMAX + 288 + 310
  173. C NRTMAX = 12 * (NPOMAX + 12)
  174. C
  175. NITMAX = (NBNMAX+NBCMAX)*NBEMAX +
  176. > NPOMAX +
  177. > MAX(7*NPOMAX , 6*NBADET+10) + 288
  178. C
  179. C ITRNOE,ITRTRI, NOETRI,ITRAV (MAX SMAOCR,R2RAF)
  180. C
  181. C
  182. NRTMAX = (IDIMC*NPOMAX) +
  183. > NBEMAX +
  184. > 2*NBEMAX +
  185. > (IDIMC*NBEMAX) +
  186. > (IDIMC*NPOMAX) + 224
  187. C
  188. C ICOORD, RADEC, ? , ITRAV (SPHERES+COORD)
  189. C
  190. C
  191. *
  192. * TRANSFERT DANS LA STRUCTURE DE L'ALGO
  193. * =====================================
  194. *
  195. ICOORD = 1
  196. ITRNOE = 1
  197. IDE = 2
  198. NCC = 1
  199. C --- INITIALISATION EN CAS DE REALLOCATION ---
  200. NBE = NBEINI
  201. *
  202. * REMPLISSAGE DU TABLEAU DE CONNEXION
  203. * ===================================
  204. SEGACT IPT1
  205. ITOTAI= NITMAX
  206. SEGINI ITRAVX
  207. segact mcoord*mod
  208. NBANC = nbpts
  209. SEGINI,ICPR,ICPP
  210. ITOTAR = NRTMAX
  211. SEGINI RTRAV
  212. MRIADEC = NPOMAX
  213. SEGINI IRADEC
  214. INO = 0
  215. DO 7764 I=1,NBE
  216. DO 7764 J=1,NBNMAX
  217. IA = IPT1.NUM(J,I)
  218. IF( ICPR(IA).EQ.0 ) THEN
  219. INO = INO+1
  220. ICPR(IA) = INO
  221. ICPP(INO)= IA
  222. DO 7763 K=1,IDIMC
  223. RTVL((INO-1)*IDIMC+K+ICOORD-1)=
  224. > XCOOR((IA-1)*(IDIM+1)+K)
  225. 7763 CONTINUE
  226. C --- PAR DEFAUT : LA DENSITE PONCTUELLE ---
  227. RADEC(INO) = XCOOR(IA*(IDIM+1))
  228. ENDIF
  229. ITVL((I-1)*NBNMAX +J+ITRNOE-1) = ICPR(IA)
  230. 7764 CONTINUE
  231. NBN = INO
  232. NBNINI = INO
  233. SEGDES IPT1
  234. C
  235. C ON A LE NOMBRE EXACT DE NOEUDS DANS LE MAILLAGE
  236. C
  237. NPONEW=NPOMAX-NBN
  238. IF( NPONEW.LE.0 )THEN
  239. IF( NBNTOT.NE.-1)THEN
  240. C Le nombre de noeuds ne peut ètre inférieur à %i1
  241. C (nombre de noeuds existants)
  242. INTERR(1) = NBN
  243. CALL ERREUR(844)
  244. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  245. GOTO 999
  246. ENDIF
  247. NPOMAX = 5 * NBN
  248. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  249. C Patience on reprend avec plus de mémoire...
  250. CALL ERREUR(850)
  251. GOTO 6
  252. ENDIF
  253. *
  254. IF(PCHPOI.EQ.1)THEN
  255. *
  256. * TRANSFERT DE LA DENSITE
  257. * -----------------------
  258. SEGACT MCHPO1,MSOUP1,MPOVA1
  259. IF( MPOVA1.VPOCHA(/1).NE.NBN )THEN
  260. SEGDES MCHPO1,MSOUP1,MPOVA1
  261. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  262. C La densité (CHPOINT) doit ètre définie sur LE maillage donné.
  263. CALL ERREUR(843)
  264. GOTO 999
  265. ENDIF
  266. * LECTURE DU MAILLAGE ASSOCIE AU CHPOINT
  267. IPT2 = MSOUP1.IGEOC
  268. SEGACT IPT2
  269. NBE2 = IPT2.NUM(/2)
  270. NBNN2 = IPT2.NUM(/1)
  271. C SEGINI IRADEC
  272. NRIADC = MPOVA1.VPOCHA(/1)
  273. *
  274. DO 8000 I=1,NRIADC
  275. * ------- LECTURE DE L'ANCIEN NUMERO ---------
  276. IA = IPT2.NUM(1,I)
  277. * ------- NOUVEAU NUMERO --------
  278. INO = ICPR(IA)
  279. IF((INO.LT.1).OR.(INO.GT.NRIADC))THEN
  280. SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2
  281. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  282. C La densité (CHPOINT) doit ètre définie sur LE maillage donné.
  283. CALL ERREUR(843)
  284. GOTO 999
  285. ENDIF
  286. RADEC(INO) = MPOVA1.VPOCHA(I,1)
  287. 8000 CONTINUE
  288. SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2
  289. ELSE
  290. * --------------------------------------------------
  291. * PAS DE CHPOINT => ON VERIFIE QUE LA DENSITE DONNEE
  292. C PAR RADEC(INO) = XCOORD(IA,3) EST ACCEPTABLE
  293. * --------------------------------------------------
  294. NRIADC = NBNINI
  295. DO 8001 INO=1,NBNINI
  296. IF( RADEC(INO).LE.0 )GOTO 8002
  297. 8001 CONTINUE
  298. GOTO 8004
  299. 8002 NRIADC = 0
  300. 8004 CONTINUE
  301. ENDIF
  302. *
  303. C =======================
  304. C --- 1.1. ALLOCATION ---
  305. C =======================
  306. C
  307. C
  308. ITRTRI = ITRNOE + (NBEMAX * NBNMAX)
  309. NOETRI = ITRTRI + (NBEMAX * NBCMAX)
  310. ITRAV = NOETRI + NPOMAX
  311. NITMX2 = NITMAX - ITRAV
  312. IRTRAV = NPOMAX * IDIMC + 1
  313. NRTMX2 = NRTMAX - IRTRAV
  314. NOEMAX = NPOMAX
  315. C
  316. C =========================================
  317. C --- 2. CREATION DE LA STRUCTURE DE DONNEES ---
  318. C =========================================
  319. C
  320. *
  321. CALL SMAOCR(IDE,ITVL(ITRNOE),NBE,RTVL(ICOORD),
  322. > NBN,IDIMC,
  323. > ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),
  324. > NBCMAX,ITVL(NOETRI),NOEMAX,
  325. > ITVL(ITRAV),NITMX2,NCC,IERRDS)
  326. C
  327. IF( IERRDS.NE.0 )THEN
  328. IF( IERRDS.EQ.-2 )THEN
  329. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  330. CALL ERREUR(850)
  331. ICMEMO = ICMEMO + 1
  332. IERRDS = 0
  333. GOTO 5
  334. ENDIF
  335. C Maillage incorrect ?!!!
  336. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  337. CALL ERREUR(844)
  338. GOTO 999
  339. ENDIF
  340. C
  341. C ==================================
  342. C --- 3. GENERATION DES NOEUDS ET
  343. C INSERTION DANS LA TRIANGULATION ---
  344. C ==================================
  345. C
  346. NITMX2 = NITMAX - ITRAV
  347. IRTRAV = NPOMAX * IDIMC + 1
  348. NRTMX2 = NRTMAX - IRTRAV
  349. NOEMAX = NPOMAX
  350. C
  351. IF( NRIADC.EQ. 0 )THEN
  352. C ========================
  353. C --- RAFFINEMENT PAR DEFAUT ---
  354. C ========================
  355. *
  356. CALL R2RAF(ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),NBCMAX,
  357. > ITVL(NOETRI),NOEMAX,
  358. > RTVL(ICOORD),NBN,NBE,NPOMAX,NBEMAX,
  359. > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
  360. > IERRDS)
  361. ELSE
  362. C ========================
  363. C --- RAFFINEMENT ITERATIF ---
  364. C ========================
  365. C
  366. CALL R2CPO(IADEC,RADEC,
  367. C CALL R2CPO(D2CHPO,IADEC,RADEC, modif TC
  368. > ITVL(ITRNOE),NBNMAX,
  369. > ITVL(ITRTRI),NBCMAX,
  370. > ITVL(NOETRI),NOEMAX,
  371. > RTVL(ICOORD),IDIMC,NBN,NBE,NPOMAX,NBEMAX,
  372. > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
  373. > NBENEW,IERRDS)
  374. ENDIF
  375. C
  376. C
  377. IF(IERRDS.NE.0)THEN
  378. IF(IERRDS.EQ.-2)THEN
  379. IF(NBNTOT.EQ.-1)THEN
  380. C PAS DE LIMITATION SUR LES NOEUDS, LA MEMOIRE EVALUEE
  381. C EST INSUFFISANTE
  382. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  383. ICMEMO = ICMEMO + 1
  384. C Patience on reprend avec plus de mémoire...
  385. CALL ERREUR(850)
  386. IERRDS = 0
  387. GOTO 5
  388. ENDIF
  389. C LIMITATION SUR LES NOEUDS DONNE PAR L'UTILISATEUR
  390. IERRDS = 0
  391. GOTO 40
  392. ENDIF
  393. C IERRDS = -1 ...
  394. CALL ERREUR(848)
  395. C ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
  396. C CALL ERREUR(27)
  397. IERRDS = 0
  398. GOTO 40
  399. ENDIF
  400. C
  401. *
  402. * REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
  403. * ============================================================
  404. 40 CONTINUE
  405. NBELEM=NBE
  406. NBNN=3
  407. NBREF=0
  408. NBSOUS=0
  409. SEGINI MELEME
  410. NBPTS = NBN-NBNINI+NBANC
  411. SEGADJ MCOORD
  412. DO 7781 I=1,NBN-NBNINI
  413. XCOOR((NBANC +I-1)*(IDIM+1) +1) = RTVL((NBNINI+I-1)*IDIMC+1)
  414. XCOOR((NBANC +I-1)*(IDIM+1) +2) = RTVL((NBNINI+I-1)*IDIMC+2)
  415. * ---- POUR LA DENSITE : DENSITE COURANTE ----
  416. XCOOR((NBANC +I-1)*(IDIM+1) +3) = DENSIT
  417. 7781 CONTINUE
  418. *
  419. DO 7782 I=1,NBE
  420. DO 7783 J=1,3
  421. IA=ITVL((I-1)*NBNMAX +J-1+ITRNOE)
  422. C
  423. IF ( IA .LE.NBNINI) THEN
  424. IB = ICPP(IA)
  425. ELSE
  426. IB = IA -NBNINI +NBANC
  427. ENDIF
  428. NUM(J,I)=IB
  429. 7783 CONTINUE
  430. ICOLOR(I) = IDCOUL
  431. 7782 CONTINUE
  432. ITYPEL=4
  433. SEGDES MELEME
  434. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  435. CALL ECROBJ('MAILLAGE',MELEME)
  436. C
  437. C
  438. 999 END
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  
  448.  
  449.  
  450.  
  451.  
  452.  

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