Télécharger manuch.eso

Retour à la liste

Numérotation des lignes :

  1. C MANUCH SOURCE BP208322 15/06/09 21:15:00 8542
  2. SUBROUTINE MANUCH
  3. ************************************************************************
  4. * NOM : MANUCH
  5. * DESCRIPTION : Cree et initialise un objet de type CHPOINT
  6. ************************************************************************
  7. * SYNTAXE (GIBIANE) :
  8. *
  9. * CHPO1 = MANU 'CHPO' GEO1 | LMOT1 LREE1 |
  10. * | |
  11. * |(ENTI1) MOT1 VAL1 MOT2 VAL2 |
  12. * | --------- --------- |
  13. * | |___________| |
  14. * | ENTI1 fois |
  15. * ('TITRE' MOT3)
  16. * ('NATURE' MOT4) ;
  17. *
  18. ************************************************************************
  19. IMPLICIT INTEGER(I-N)
  20. -INC CCOPTIO
  21. -INC SMCHPOI
  22. -INC SMLMOTS
  23. -INC SMLREEL
  24. -INC SMELEME
  25. -INC SMCOORD
  26. *
  27. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  28. SEGMENT ICP1(NBP1),ICP2(NBP2)
  29. SEGMENT IPLREE(JG)
  30. *
  31. REAL*8 VFLOT
  32. CHARACTER*(6) MOYY
  33. CHARACTER*72 TITRE
  34. *
  35. * MOOPT CONTIENT LES MOTS-CLES DE L'OPERATEUR
  36. PARAMETER (LMOOPT=2)
  37. CHARACTER*4 MOOPT(LMOOPT)
  38. DATA MOOPT /'TITR','NATU'/
  39. *
  40. * ADDI CONTIENT LES MOTS-CLES DU PREMIER ATTRIBUT (NATURE)
  41. CHARACTER*4 ADDI(3)
  42. DATA ADDI /'INDE','DIFF','DISC'/
  43. *
  44. * ATTRI CONTIENT LES VALEURS DES ATTRIBUTS (LIMITE A 10)
  45. INTEGER ATTRI(10)
  46. *
  47. * BOOLEEN INDIQUANT SI ON A DONNE UN MAILLAGE DE POI1
  48. LOGICAL KPOI1
  49. *
  50. * BOOLEEN INDIQUANT QU'AU MOINS UNE COMPOSANTE EST VARIABLE
  51. LOGICAL KVARI
  52. KVARI = .FALSE.
  53. *
  54. *
  55. *
  56. * +---------------------------------------------------------------+
  57. * | L E C T U R E D E S M O T S - C L E S |
  58. * +---------------------------------------------------------------+
  59. * (DANS LE CAS OU ILS SONT PLACES EN TETE D'INSTRUCTION)
  60. *
  61. TITRE = ' '
  62. DO I=1,10
  63. ATTRI(I)=0
  64. ENDDO
  65. *
  66. 100 CALL LIRMOT(MOOPT,LMOOPT,IMOT,0)
  67. IF (IERR.NE.0) RETURN
  68. *
  69. * MOT-CLE "TITR"
  70. * ==============
  71. IF (IMOT.EQ.1) THEN
  72. CALL LIRCHA(TITRE,1,IRETOU)
  73. IF (IERR.NE.0) RETURN
  74. GOTO 100
  75. *
  76. * MOT-CLE "NATU"
  77. * ==============
  78. ELSEIF (IMOT.EQ.2) THEN
  79. CALL LIRMOT(ADDI,3,ATTRI(1),1)
  80. IF (IERR .NE. 0) RETURN
  81. ATTRI(1) = ATTRI(1) - 1
  82. GOTO 100
  83. ENDIF
  84. *
  85. *
  86. *
  87. * +---------------------------------------------------------------+
  88. * | L E C T U R E D E L A G E O M E T R I E |
  89. * +---------------------------------------------------------------+
  90. *
  91. * GEOMETRIE SOUS FORME DE "POINT"
  92. CALL LIROBJ('POINT ',KPOINT,0,IRETOU)
  93. IF (IRETOU.NE.0) THEN
  94. CALL CRELEM(KPOINT)
  95. MELEME = KPOINT
  96. SEGACT MELEME
  97. KPOI1 = .TRUE.
  98. *
  99. * GEOMETRIE SOUS FORME DE "MAILLAGE"
  100. ELSE
  101. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  102. IF (IERR.NE.0) RETURN
  103. SEGACT MELEME
  104. KPOI1 = (ITYPEL.EQ.1.AND.LISOUS(/1).EQ.0)
  105. ENDIF
  106. *
  107. * NBP1 = Nombre de noeuds avec doublons eventuels
  108. * NBP2 = Nombre de noeuds sans aucun doublon
  109. *
  110. * CREATION D'UN MAILLAGE DE POI1 SANS DOUBLONS
  111. IF (KPOI1) THEN
  112. *
  113. * BOUCLE SUR LES NOEUDS DU MAILLAGE
  114. * => ON DETECTE LES DOUBLONS EVENTUELS EN REMPLISSANT ICPR
  115. * => ON CREE IPT1, LE MAILLAGE CORRESPONDANT A MELEME SANS LES DOUBLONS
  116. * (ON LE CREE MANUELLEMENT PLUTOT QUE D'APPELER "CHANGE"
  117. * AFIN DE MAITRISER LA NUMEROTATION DE NOEUDS DANS IPT1
  118. * ET ETRE SUR DE LA BONNE CORRESPONDANCE AVEC LE MLREEL)
  119. * => DANS ICP1, ON RELIE LE RANG DANS MELEME AU RANG DANS IPT1 :
  120. * ICP1(RANG_AVEC_DOUBLONS) = RANG_SANS_DOUBLONS
  121. NBP1 = NUM(/2)
  122. NBP2 = 0
  123. *
  124. SEGINI ICPR,ICP1
  125. *
  126. NBNN=1
  127. NBELEM=NBP1
  128. NBSOUS=0
  129. NBREF=0
  130. SEGINI IPT1
  131. IPT1.ITYPEL=1
  132. *
  133. DO I=1,NBP1
  134. IKI = NUM(1,I)
  135. IF (ICPR(IKI).EQ.0) THEN
  136. NBP2 = NBP2+1
  137. ICPR(IKI) = NBP2
  138. IPT1.NUM(1,NBP2) = IKI
  139. ENDIF
  140. ICP1(I) = ICPR(IKI)
  141. ENDDO
  142. *
  143. SEGSUP ICPR
  144. *
  145. SEGDES MELEME
  146. *bp : ajout du cas ou NBP2 = NBP1 : on conserve le bon MELEME
  147. if (NBP2.eq.NBP1) then
  148. SEGSUP,IPT1
  149. else
  150. * On peut desormais remplacer MELEME par IPT1
  151. NBELEM=NBP2
  152. SEGADJ IPT1
  153. *bp : ajout de la verif que ce maillage n existe pas deja via crech1
  154. ipt11=ipt1
  155. call crech1(ipt1,1)
  156. MELEME = IPT1
  157. if (IPT1.ne.ipt11) then
  158. IPT1=ipt11
  159. segsup,IPT1
  160. endif
  161. endif
  162. *
  163. ELSE
  164. *
  165. * L'APPEL A "CHANGE" SUFFIT POUR ELIMINER TOUS LES DOUBLONS
  166. CALL CHANGE(MELEME,1)
  167. NBP1 = NUM(/2)
  168. NBP2 = NBP1
  169. *
  170. ENDIF
  171. *
  172. SEGDES MELEME
  173. *
  174. *
  175. * +---------------------------------------------------------------+
  176. * | L E C T U R E D E S C O M P O S A N T E S |
  177. * +---------------------------------------------------------------+
  178. *
  179. *
  180. * SYNTAXE 1
  181. * =========
  182. *
  183. * MANU 'CHPO' GEO1 LMOT1 LREE1 ;
  184. * => ATTRIBUE UNE VALEUR CONSTANTE A CHAQUE COMPOSANTE (NULLE SI
  185. * PLUS DE COMPOSANTES DANS LMOT1 QUE DE VALEURS DANS LREE1)
  186. *
  187. CALL LIROBJ('LISTMOTS',MLMOTS,0,ISYNTA1)
  188. IF (ISYNTA1.NE.0) THEN
  189. *
  190. * NC = Nombre de noms de composantes dans le LISTMOTS
  191. * NR = Nombre de valeurs reelles dans le LISTREEL
  192. *
  193. *
  194. * LECTURE DES NOMS
  195. * ****************
  196. *
  197. SEGACT MLMOTS
  198. NC = MOTS(/2)
  199. ILU = 1
  200.  
  201. * LECTURE DES VALEURS
  202. * *******************
  203. *
  204. CALL LIROBJ('LISTREEL',MLREEL,1,IRETOU)
  205. IF (IERR.NE.0) RETURN
  206. SEGACT MLREEL
  207. NR = PROG(/1)
  208. JG = NC
  209. SEGINI IPLREE
  210. c DO I=1,NC
  211. c IPLREE(I)=0
  212. c ENDDO
  213. IF (NR.LT.NC) THEN
  214. SEGADJ MLREEL
  215. DO I=NR+1,NC
  216. PROG(I)=0.D0
  217. ENDDO
  218. ENDIF
  219. *
  220. *
  221. * SYNTAXE 2
  222. * =========
  223. *
  224. * MANU 'CHPO' GEO1 (ENTI1) MOT1 VAL1 (MOT2 VAL2 ...) ;
  225. * => ATTRIBUE UNE VALEUR OU UNE LISTE DE VALEURS A CHAQUE COMPOSANTE
  226. * (LES VALi PEUVENT ETRE DE TYPE FLOTTANT OU LISTREEL)
  227. *
  228. ELSE
  229. *
  230. * ILU = 1 si le nombre de composantes est specifie (0 sinon)
  231. * NCC = Nombre de composantes indique par l'utilisateur
  232. * NC = Nombre de composantes lues dans MOT1, MOT2, etc...
  233. CALL LIRENT(NCC,0,IRETOU)
  234. IF (IRETOU.NE.0) THEN
  235. ILU=1
  236. INTERR(1)= NCC
  237. IF (NCC.LE.0) CALL ERREUR(36)
  238. IF (IERR.NE.0) RETURN
  239. JGN=4
  240. JGM=NCC
  241. JG=NCC
  242. ELSE
  243. ILU=0
  244. JGN=4
  245. JGM=1
  246. JG=0
  247. ENDIF
  248. SEGINI MLMOTS,MLREEL,IPLREE
  249. *
  250. NC = 0
  251. *
  252. 20 CONTINUE
  253. *
  254. *
  255. * LECTURE DU NOM
  256. * **************
  257. *
  258. CALL LIRCHA(MOYY,0,IRETOU)
  259. IF (IRETOU.EQ.0) THEN
  260. IF (ILU.EQ.1) THEN
  261. CALL ERREUR(80)
  262. RETURN
  263. ELSE
  264. GOTO 21
  265. ENDIF
  266. ENDIF
  267. IF (IERR.NE.0) RETURN
  268. *
  269. IF (IRETOU.GT.4) THEN
  270. CALL ERREUR(536)
  271. RETURN
  272. ENDIF
  273. *
  274. *
  275. * LECTURE DES VALEURS CORRESPONDANTES...
  276. * **************************************
  277. *
  278. * ...SOUS-FORME DE FLOTTANT ?
  279. CALL LIRREE(VFLOT,0,IFLO)
  280. *
  281. * ...OU SOUS-FORME DE LISTREEL ?
  282. IF (IFLO.EQ.0) THEN
  283. CALL LIROBJ('LISTREEL',MLREE1,1,ILIS)
  284. IF (IERR.NE.0) RETURN
  285. *
  286. SEGACT MLREE1
  287. N = MLREE1.PROG(/1)
  288. *
  289. IF (N.NE.NBP1.AND.N.NE.1) CALL ERREUR(726)
  290. IF (IERR.NE.0) RETURN
  291. *
  292. * ...FINALEMENT NON, C'EST BIEN UN UNIQUE FLOTTANT !
  293. IF (N.EQ.1) THEN
  294. VFLOT = MLREE1.PROG(1)
  295. SEGDES MLREE1
  296. IFLO = 1
  297. ENDIF
  298. ENDIF
  299. *
  300. *
  301. * MEMORISATION DES NOMS DANS MLMOTS
  302. * MEMORISATION DES VALEURS DANS MLREEL OU IPLREE
  303. * **********************************************
  304. *
  305. NC = NC + 1
  306. *
  307. IF (ILU.EQ.0) THEN
  308. JGM = NC
  309. JG = NC
  310. SEGADJ MLMOTS,MLREEL,IPLREE
  311. ENDIF
  312. *
  313. MOTS(NC) = MOYY(1:4)
  314. *
  315. IF (IFLO.NE.0) THEN
  316. IPLREE(NC) = 0
  317. PROG(NC) = VFLOT
  318. ELSE
  319. KVARI = .TRUE.
  320. IPLREE(NC) = MLREE1
  321. ENDIF
  322. *
  323. IF (ILU.EQ.0.OR.NC.LT.NCC) GOTO 20
  324. 21 CONTINUE
  325. *
  326. ENDIF
  327. *
  328. *
  329. *
  330. * +---------------------------------------------------------------+
  331. * | L E C T U R E D E S M O T S - C L E S |
  332. * +---------------------------------------------------------------+
  333. * (DANS LE CAS OU ILS SONT PLACES EN FIN D'INSTRUCTION)
  334. *
  335. 200 CONTINUE
  336. CALL LIRMOT(MOOPT,LMOOPT,IMOT,0)
  337. IF (IERR.NE.0) RETURN
  338. *
  339. * MOT-CLE "TITR"
  340. * ==============
  341. IF (IMOT.EQ.1) THEN
  342. CALL LIRCHA(TITRE,1,IRETOU)
  343. IF (IERR.NE.0) RETURN
  344. GOTO 200
  345. *
  346. * MOT-CLE "NATU"
  347. * ==============
  348. ELSEIF (IMOT.EQ.2) THEN
  349. CALL LIRMOT(ADDI,3,ATTRI(1),1)
  350. IF (IERR .NE. 0) RETURN
  351. ATTRI(1) = ATTRI(1) - 1
  352. GOTO 200
  353. ENDIF
  354. *
  355. *
  356. *
  357. * +---------------------------------------------------------------+
  358. * | C R E A T I O N D U C H P O I N T |
  359. * +---------------------------------------------------------------+
  360. *
  361. *
  362. IF (.NOT.KPOI1.AND.KVARI) CALL ERREUR(1040)
  363. IF (IERR.NE.0) RETURN
  364. *
  365. IF (NBP1.NE.NBP2.AND.ATTRI(1).EQ.0) CALL ERREUR(1041)
  366. IF (IERR.NE.0) RETURN
  367. *
  368. *
  369. * INITIALISATION DES SEGMENTS MSOUPO ET MPOVAL DU CHPOINT
  370. * =======================================================
  371. *
  372. SEGINI MSOUPO
  373. IGEOC = MELEME
  374. N = NBP2
  375. *
  376. SEGINI MPOVAL
  377. IPOVAL = MPOVAL
  378. *
  379. *
  380. * BOUCLE SUR LES COMPOSANTES A CREER
  381. * ==================================
  382. *
  383. DO IC=1,NC
  384. *
  385. NOHARM(IC) = NIFOUR
  386. NOCOMP(IC) = MOTS(IC)(1:4)
  387. *l
  388. IF (IPLREE(IC).EQ.0) THEN
  389. *
  390. * -------------------
  391. * COMPOSANTE UNIFORME
  392. * -------------------
  393. *
  394. VFLOT=PROG(IC)
  395. *
  396. * Maillage initial sans noeuds multiples
  397. IF (NBP1.EQ.NBP2) THEN
  398. DO K=1,NBP1
  399. VPOCHA(K,IC) = VFLOT
  400. ENDDO
  401. *
  402. * Noeuds multiples + Nature DIFFUSE
  403. ELSEIF (ATTRI(1).EQ.1) THEN
  404. DO K=1,NBP2
  405. VPOCHA(K,IC) = VFLOT
  406. ENDDO
  407. *
  408. * Noeuds multiples + Nature DISCRETE
  409. ELSEIF (ATTRI(1).EQ.2) THEN
  410. DO K=1,NBP1
  411. K1=ICP1(K)
  412. VPOCHA(K1,IC) = VPOCHA(K1,IC) + VFLOT
  413. ENDDO
  414. ENDIF
  415. *
  416. ELSE
  417. *
  418. * -------------------
  419. * COMPOSANTE VARIABLE
  420. * -------------------
  421. *
  422. MLREE1=IPLREE(IC)
  423. SEGACT MLREE1
  424. *
  425. * Maillage initial sans noeuds multiples
  426. IF (NBP1.EQ.NBP2) THEN
  427. DO K=1,NBP1
  428. VPOCHA(K,IC) = MLREE1.PROG(K)
  429. ENDDO
  430. *
  431. * Noeuds multiples + Nature DIFFUSE
  432. ELSEIF (ATTRI(1).EQ.1) THEN
  433. SEGINI ICP2
  434. DO K=1,NBP1
  435. K1=ICP1(K)
  436. VFLOT=MLREE1.PROG(K)
  437. IF (ICP2(K1).EQ.1.AND.VPOCHA(K1,IC).NE.VFLOT) THEN
  438. MOTERR(1:8)=MOTS(IC)(1:4)
  439. CALL ERREUR(1042)
  440. RETURN
  441. ENDIF
  442. VPOCHA(K1,IC) = VPOCHA(K1,IC) + VFLOT
  443. ICP2(K1)=1
  444. ENDDO
  445. SEGSUP ICP2
  446. *
  447. * Noeuds multiples + Nature DISCRETE
  448. ELSEIF (ATTRI(1).EQ.2) THEN
  449. DO K=1,NBP1
  450. K1=ICP1(K)
  451. VPOCHA(K1,IC) = VPOCHA(K1,IC) + MLREE1.PROG(K)
  452. ENDDO
  453. ENDIF
  454. *
  455. SEGDES MLREE1
  456. *
  457. ENDIF
  458. *
  459. ENDDO
  460. *
  461. *
  462. * Un peu de menage...
  463. IF (ISYNTA1.EQ.1) THEN
  464. SEGDES MLMOTS,MLREEL
  465. ELSE
  466. SEGSUP MLMOTS,MLREEL
  467. ENDIF
  468. SEGSUP IPLREE
  469. SEGDES MPOVAL,MSOUPO
  470. IF (KPOI1) SEGSUP ICP1
  471. *
  472. *
  473. * CREATION DU CHAPEAU
  474. * ===================
  475. *
  476. NSOUPO = 1
  477. NAT = 1
  478. SEGINI MCHPOI
  479. MOCHDE = TITRE
  480. MTYPOI = ' '
  481. DO I=1,NAT
  482. JATTRI(I) = ATTRI(I)
  483. ENDDO
  484. IFOPOI = IFOMOD
  485. IPCHP(1)= MSOUPO
  486. SEGDES MCHPOI
  487. *
  488. *
  489. * ECRITURE DU CHPOINT
  490. * ===================
  491. *
  492. CALL ECROBJ('CHPOINT',MCHPOI)
  493. *
  494. *
  495. *
  496. RETURN
  497. *
  498. END
  499. *
  500.  
  501.  

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