Télécharger manuch.eso

Retour à la liste

Numérotation des lignes :

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

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