Télécharger manuch.eso

Retour à la liste

Numérotation des lignes :

  1. C MANUCH SOURCE CB215821 19/07/30 21:17:15 10273
  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.  
  53. SEGACT,MCOORD
  54. KVARI = .FALSE.
  55. *
  56. *
  57. *
  58. * +---------------------------------------------------------------+
  59. * | L E C T U R E D E S M O T S - C L E S |
  60. * +---------------------------------------------------------------+
  61. * (DANS LE CAS OU ILS SONT PLACES EN TETE D'INSTRUCTION)
  62. *
  63. TITRE = ' '
  64. DO I=1,10
  65. ATTRI(I)=0
  66. ENDDO
  67. *
  68. 100 CALL LIRMOT(MOOPT,LMOOPT,IMOT,0)
  69. IF (IERR.NE.0) RETURN
  70. *
  71. * MOT-CLE "TITR"
  72. * ==============
  73. IF (IMOT.EQ.1) THEN
  74. CALL LIRCHA(TITRE,1,IRETOU)
  75. IF (IERR.NE.0) RETURN
  76. GOTO 100
  77. *
  78. * MOT-CLE "NATU"
  79. * ==============
  80. ELSEIF (IMOT.EQ.2) THEN
  81. CALL LIRMOT(ADDI,3,ATTRI(1),1)
  82. IF (IERR .NE. 0) RETURN
  83. ATTRI(1) = ATTRI(1) - 1
  84. GOTO 100
  85. ENDIF
  86. *
  87. *
  88. *
  89. * +---------------------------------------------------------------+
  90. * | L E C T U R E D E L A G E O M E T R I E |
  91. * +---------------------------------------------------------------+
  92. *
  93. * GEOMETRIE SOUS FORME DE "POINT"
  94. CALL LIROBJ('POINT ',KPOINT,0,IRETOU)
  95. IF (IRETOU.NE.0) THEN
  96. CALL CRELEM(KPOINT)
  97. MELEME = KPOINT
  98. SEGACT MELEME
  99. KPOI1 = .TRUE.
  100. *
  101. * GEOMETRIE SOUS FORME DE "MAILLAGE"
  102. ELSE
  103. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  104. IF (IERR.NE.0) RETURN
  105. SEGACT MELEME
  106. KPOI1 = (ITYPEL.EQ.1.AND.LISOUS(/1).EQ.0)
  107. ENDIF
  108. *
  109. * NBP1 = Nombre de noeuds avec doublons eventuels
  110. * NBP2 = Nombre de noeuds sans aucun doublon
  111. *
  112. * CREATION D'UN MAILLAGE DE POI1 SANS DOUBLONS
  113. IF (KPOI1) THEN
  114. *
  115. * BOUCLE SUR LES NOEUDS DU MAILLAGE
  116. * => ON DETECTE LES DOUBLONS EVENTUELS EN REMPLISSANT ICPR
  117. * => ON CREE IPT1, LE MAILLAGE CORRESPONDANT A MELEME SANS LES DOUBLONS
  118. * (ON LE CREE MANUELLEMENT PLUTOT QUE D'APPELER "CHANGE"
  119. * AFIN DE MAITRISER LA NUMEROTATION DE NOEUDS DANS IPT1
  120. * ET ETRE SUR DE LA BONNE CORRESPONDANCE AVEC LE MLREEL)
  121. * => DANS ICP1, ON RELIE LE RANG DANS MELEME AU RANG DANS IPT1 :
  122. * ICP1(RANG_AVEC_DOUBLONS) = RANG_SANS_DOUBLONS
  123. NBP1 = NUM(/2)
  124. NBP2 = 0
  125. *
  126. SEGINI ICPR,ICP1
  127. *
  128. NBNN=1
  129. NBELEM=NBP1
  130. NBSOUS=0
  131. NBREF=0
  132. SEGINI IPT1
  133. IPT1.ITYPEL=1
  134. *
  135. DO I=1,NBP1
  136. IKI = NUM(1,I)
  137. IF (ICPR(IKI).EQ.0) THEN
  138. NBP2 = NBP2+1
  139. ICPR(IKI) = NBP2
  140. IPT1.NUM(1,NBP2) = IKI
  141. ENDIF
  142. ICP1(I) = ICPR(IKI)
  143. ENDDO
  144. *
  145. SEGSUP ICPR
  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. *
  173. * +---------------------------------------------------------------+
  174. * | L E C T U R E D E S C O M P O S A N T E S |
  175. * +---------------------------------------------------------------+
  176. *
  177. *
  178. * SYNTAXE 1
  179. * =========
  180. *
  181. * MANU 'CHPO' GEO1 LMOT1 LREE1 ;
  182. * => ATTRIBUE UNE VALEUR CONSTANTE A CHAQUE COMPOSANTE (NULLE SI
  183. * PLUS DE COMPOSANTES DANS LMOT1 QUE DE VALEURS DANS LREE1)
  184. *
  185. CALL LIROBJ('LISTMOTS',MLMOTS,0,ISYNTA1)
  186. IF (ISYNTA1.NE.0) THEN
  187. *
  188. * NC = Nombre de noms de composantes dans le LISTMOTS
  189. * NR = Nombre de valeurs reelles dans le LISTREEL
  190. *
  191. *
  192. * LECTURE DES NOMS
  193. * ****************
  194. *
  195. SEGACT MLMOTS
  196. NC = MOTS(/2)
  197. ILU = 1
  198.  
  199. * LECTURE DES VALEURS
  200. * *******************
  201. *
  202. CALL LIROBJ('LISTREEL',MLREEL,1,IRETOU)
  203. IF (IERR.NE.0) RETURN
  204. SEGACT MLREEL
  205. NR = PROG(/1)
  206. JG = NC
  207. SEGINI IPLREE
  208. c DO I=1,NC
  209. c IPLREE(I)=0
  210. c ENDDO
  211. IF (NR.LT.NC) THEN
  212. SEGADJ MLREEL
  213. DO I=NR+1,NC
  214. PROG(I)=0.D0
  215. ENDDO
  216. ENDIF
  217. *
  218. *
  219. * SYNTAXE 2
  220. * =========
  221. *
  222. * MANU 'CHPO' GEO1 (ENTI1) MOT1 VAL1 (MOT2 VAL2 ...) ;
  223. * => ATTRIBUE UNE VALEUR OU UNE LISTE DE VALEURS A CHAQUE COMPOSANTE
  224. * (LES VALi PEUVENT ETRE DE TYPE FLOTTANT OU LISTREEL)
  225. *
  226. ELSE
  227. *
  228. * ILU = 1 si le nombre de composantes est specifie (0 sinon)
  229. * NCC = Nombre de composantes indique par l'utilisateur
  230. * NC = Nombre de composantes lues dans MOT1, MOT2, etc...
  231. CALL LIRENT(NCC,0,IRETOU)
  232. IF (IRETOU.NE.0) THEN
  233. ILU=1
  234. INTERR(1)= NCC
  235. IF (NCC.LE.0) CALL ERREUR(36)
  236. IF (IERR.NE.0) RETURN
  237. JGN=4
  238. JGM=NCC
  239. JG=NCC
  240. ELSE
  241. ILU=0
  242. JGN=4
  243. JGM=1
  244. JG=0
  245. ENDIF
  246. SEGINI MLMOTS,MLREEL,IPLREE
  247. *
  248. NC = 0
  249. *
  250. 20 CONTINUE
  251. *
  252. *
  253. * LECTURE DU NOM
  254. * **************
  255. *
  256. CALL LIRCHA(MOYY,0,IRETOU)
  257. IF (IRETOU.EQ.0) THEN
  258. IF (ILU.EQ.1) THEN
  259. CALL ERREUR(80)
  260. RETURN
  261. ELSE
  262. GOTO 21
  263. ENDIF
  264. ENDIF
  265. IF (IERR.NE.0) RETURN
  266. *
  267. IF (IRETOU.GT.4) THEN
  268. CALL ERREUR(536)
  269. RETURN
  270. ENDIF
  271. *
  272. *
  273. * LECTURE DES VALEURS CORRESPONDANTES...
  274. * **************************************
  275. *
  276. * ...SOUS-FORME DE FLOTTANT ?
  277. CALL LIRREE(VFLOT,0,IFLO)
  278. *
  279. * ...OU SOUS-FORME DE LISTREEL ?
  280. IF (IFLO.EQ.0) THEN
  281. CALL LIROBJ('LISTREEL',MLREE1,1,ILIS)
  282. IF (IERR.NE.0) RETURN
  283. *
  284. SEGACT MLREE1
  285. N = MLREE1.PROG(/1)
  286. *
  287. IF (N.NE.NBP1.AND.N.NE.1) CALL ERREUR(726)
  288. IF (IERR.NE.0) RETURN
  289. *
  290. * ...FINALEMENT NON, C'EST BIEN UN UNIQUE FLOTTANT !
  291. IF (N.EQ.1) THEN
  292. VFLOT = MLREE1.PROG(1)
  293. IFLO = 1
  294. ENDIF
  295. ENDIF
  296. *
  297. *
  298. * MEMORISATION DES NOMS DANS MLMOTS
  299. * MEMORISATION DES VALEURS DANS MLREEL OU IPLREE
  300. * **********************************************
  301. *
  302. NC = NC + 1
  303. *
  304. IF (ILU.EQ.0) THEN
  305. JGM = NC
  306. JG = NC
  307. SEGADJ MLMOTS,MLREEL,IPLREE
  308. ENDIF
  309. *
  310. MOTS(NC) = MOYY(1:4)
  311. *
  312. IF (IFLO.NE.0) THEN
  313. IPLREE(NC) = 0
  314. PROG(NC) = VFLOT
  315. ELSE
  316. KVARI = .TRUE.
  317. IPLREE(NC) = MLREE1
  318. ENDIF
  319. *
  320. IF (ILU.EQ.0.OR.NC.LT.NCC) GOTO 20
  321. 21 CONTINUE
  322. *
  323. ENDIF
  324. *
  325. *
  326. *
  327. * +---------------------------------------------------------------+
  328. * | L E C T U R E D E S M O T S - C L E S |
  329. * +---------------------------------------------------------------+
  330. * (DANS LE CAS OU ILS SONT PLACES EN FIN D'INSTRUCTION)
  331. *
  332. 200 CONTINUE
  333. CALL LIRMOT(MOOPT,LMOOPT,IMOT,0)
  334. IF (IERR.NE.0) RETURN
  335. *
  336. * MOT-CLE "TITR"
  337. * ==============
  338. IF (IMOT.EQ.1) THEN
  339. CALL LIRCHA(TITRE,1,IRETOU)
  340. IF (IERR.NE.0) RETURN
  341. GOTO 200
  342. *
  343. * MOT-CLE "NATU"
  344. * ==============
  345. ELSEIF (IMOT.EQ.2) THEN
  346. CALL LIRMOT(ADDI,3,ATTRI(1),1)
  347. IF (IERR .NE. 0) RETURN
  348. ATTRI(1) = ATTRI(1) - 1
  349. GOTO 200
  350. ENDIF
  351. *
  352. *
  353. *
  354. * +---------------------------------------------------------------+
  355. * | C R E A T I O N D U C H P O I N T |
  356. * +---------------------------------------------------------------+
  357. *
  358. *
  359. IF (.NOT.KPOI1.AND.KVARI) CALL ERREUR(1040)
  360. IF (IERR.NE.0) RETURN
  361. *
  362. IF (NBP1.NE.NBP2.AND.ATTRI(1).EQ.0) CALL ERREUR(1041)
  363. IF (IERR.NE.0) RETURN
  364. *
  365. *
  366. * INITIALISATION DES SEGMENTS MSOUPO ET MPOVAL DU CHPOINT
  367. * =======================================================
  368. *
  369. SEGINI MSOUPO
  370. IGEOC = MELEME
  371. N = NBP2
  372. *
  373. SEGINI MPOVAL
  374. IPOVAL = MPOVAL
  375. *
  376. *
  377. * BOUCLE SUR LES COMPOSANTES A CREER
  378. * ==================================
  379. *
  380. DO IC=1,NC
  381. *
  382. NOHARM(IC) = NIFOUR
  383. NOCOMP(IC) = MOTS(IC)(1:4)
  384. *l
  385. IF (IPLREE(IC).EQ.0) THEN
  386. *
  387. * -------------------
  388. * COMPOSANTE UNIFORME
  389. * -------------------
  390. *
  391. VFLOT=PROG(IC)
  392. *
  393. * Maillage initial sans noeuds multiples
  394. IF (NBP1.EQ.NBP2) THEN
  395. DO K=1,NBP1
  396. VPOCHA(K,IC) = VFLOT
  397. ENDDO
  398. *
  399. * Noeuds multiples + Nature DIFFUSE
  400. ELSEIF (ATTRI(1).EQ.1) THEN
  401. DO K=1,NBP2
  402. VPOCHA(K,IC) = VFLOT
  403. ENDDO
  404. *
  405. * Noeuds multiples + Nature DISCRETE
  406. ELSEIF (ATTRI(1).EQ.2) THEN
  407. DO K=1,NBP1
  408. K1=ICP1(K)
  409. VPOCHA(K1,IC) = VPOCHA(K1,IC) + VFLOT
  410. ENDDO
  411. ENDIF
  412. *
  413. ELSE
  414. *
  415. * -------------------
  416. * COMPOSANTE VARIABLE
  417. * -------------------
  418. *
  419. MLREE1=IPLREE(IC)
  420. SEGACT MLREE1
  421. *
  422. * Maillage initial sans noeuds multiples
  423. IF (NBP1.EQ.NBP2) THEN
  424. DO K=1,NBP1
  425. VPOCHA(K,IC) = MLREE1.PROG(K)
  426. ENDDO
  427. *
  428. * Noeuds multiples + Nature DIFFUSE
  429. ELSEIF (ATTRI(1).EQ.1) THEN
  430. SEGINI ICP2
  431. DO K=1,NBP1
  432. K1=ICP1(K)
  433. VFLOT=MLREE1.PROG(K)
  434. IF (ICP2(K1).EQ.1.AND.VPOCHA(K1,IC).NE.VFLOT) THEN
  435. MOTERR(1:8)=MOTS(IC)(1:4)
  436. CALL ERREUR(1042)
  437. RETURN
  438. ENDIF
  439. VPOCHA(K1,IC) = VPOCHA(K1,IC) + VFLOT
  440. ICP2(K1)=1
  441. ENDDO
  442. SEGSUP ICP2
  443. *
  444. * Noeuds multiples + Nature DISCRETE
  445. ELSEIF (ATTRI(1).EQ.2) THEN
  446. DO K=1,NBP1
  447. K1=ICP1(K)
  448. VPOCHA(K1,IC) = VPOCHA(K1,IC) + MLREE1.PROG(K)
  449. ENDDO
  450. ENDIF
  451. *
  452. ENDIF
  453. *
  454. ENDDO
  455. *
  456. *
  457. * Un peu de menage...
  458. IF (ISYNTA1.NE.1) THEN
  459. SEGSUP MLMOTS,MLREEL
  460. ENDIF
  461. SEGSUP IPLREE
  462. IF (KPOI1) SEGSUP ICP1
  463. *
  464. *
  465. * CREATION DU CHAPEAU
  466. * ===================
  467. *
  468. NSOUPO = 1
  469. NAT = 1
  470. SEGINI MCHPOI
  471. MOCHDE = TITRE
  472. MTYPOI = ' '
  473. DO I=1,NAT
  474. JATTRI(I) = ATTRI(I)
  475. ENDDO
  476. IFOPOI = IFOMOD
  477. IPCHP(1)= MSOUPO
  478. *
  479. *
  480. * ECRITURE DU CHPOINT
  481. * ===================
  482. *
  483. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  484. CALL ECROBJ('CHPOINT ',MCHPOI)
  485.  
  486. END
  487.  
  488.  
  489.  

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