Télécharger pod.eso

Retour à la liste

Numérotation des lignes :

  1. C POD SOURCE BP208322 17/04/18 21:15:09 9396
  2. SUBROUTINE POD
  3. ************************************************************************
  4. * NOM : POD
  5. * DESCRIPTION : Calcule la decomposition POD (Proper Orthogonalized
  6. * Decomposition) d'un signal spatio-temporel
  7. ************************************************************************
  8. * APPELE PAR : pilot.eso
  9. ************************************************************************
  10. * SOUS-PROGRAMMES : tuu.eso => produit tU*U
  11. * tumu.eso => produit tU*M*U
  12. * utu.eso => produit U*tU
  13. * utum.eso => produit U*tU*M
  14. ************************************************************************
  15. * SYNTAXE (GIBIANE) :
  16. *
  17. * (...) = POD |LDATA1 | (LENTI1) |'SNAPSHOTS'| (MASS1) ----+
  18. * |MOT1 (MOT2) TAB1| |'CLASSIQUE'| |
  19. * |
  20. * +----------------------------------+
  21. * |
  22. * |
  23. * +----> NBMOD ('TBAS' (MAIL1)) ;
  24. *
  25. ************************************************************************
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8 (A-H,O-Z)
  28. -INC CCOPTIO
  29. -INC CCASSIS
  30. -INC CCNOYAU
  31. -INC SMTABLE
  32. -INC SMLCHPO
  33. -INC SMCHPOI
  34. -INC SMELEME
  35. -INC SMLENTI
  36. -INC SMLMOTS
  37. -INC SMLREEL
  38. -INC SMRIGID
  39. -INC SMSOLUT
  40. -INC CCREEL
  41. POINTEUR LCOMP.MLMOTS
  42. *
  43. PARAMETER (NMET=2)
  44. CHARACTER*4 MMET(NMET)
  45. DATA MMET/'SNAP','CLAS'/
  46. *
  47. CHARACTER*4 CHA4
  48. CHARACTER*8 CHA8
  49. CHARACTER*32 CHA32
  50. CHARACTER*40 CHA40,CHB40
  51. LOGICAL ZLOGI
  52. *
  53. COMPLEX*16 SHIFT
  54. *
  55. * TMODE = SEGMENTS DE TRAVAIL UTILISES POUR STOCKER LES VALEURS ET
  56. * LES VECTEURS PROPRES CONTENUS DANS L'OBJET SOLUTION
  57. SEGMENT TMODE
  58. INTEGER IMOD(NBSOL)
  59. REAL*8 XMOD(NBSOL)
  60. ENDSEGMENT
  61. *
  62. * TRAV1,TRAV2 = SEGMENTS DE TRAVAIL UTILISES LORS D'APPELS A ORDO
  63. SEGMENT TRAV1
  64. INTEGER ITRA((NTRA+1)/2)
  65. ENDSEGMENT
  66. SEGMENT TRAV2
  67. INTEGER IORD(NTRA)
  68. REAL*8 XORD(NTRA)
  69. REAL*8 XTRA((NTRA+1)/2)
  70. ENDSEGMENT
  71. *
  72. * TICHPO,TXCOEF = SEGMENTS UTILISES POUR L'APPEL A L'OPERATEUR COLI
  73. SEGMENT/TICHPO/(ICHPO(NCH))
  74. SEGMENT/TXCOEF/(XCOEF(NCH)*D)
  75. *
  76. ************************************************************************
  77. *
  78. * OPERATEUR UTILISABLE SEULEMENT EN 2D OU EN 3D
  79. IF (IDIM.EQ.1) THEN
  80. INTERR(1)=1
  81. CALL ERREUR(709)
  82. RETURN
  83. ENDIF
  84. *
  85. *
  86. * +---------------------------------------------------------------+
  87. * | |
  88. * | L E C T U R E D E S A R G U M E N T S |
  89. * | |
  90. * +---------------------------------------------------------------+
  91. *
  92. *
  93. * +---------------------------------------------------------------+
  94. * | S I G N A L D ' E N T R E E |
  95. * +---------------------------------------------------------------+
  96. *
  97. IPRO=0
  98. CALL LIRRES(ILCHP1,1,IPRO,CHA32,NCH,0,ILREE1)
  99. IF (IERR.NE.0) RETURN
  100. *
  101. * FILTRAGE EVENTUEL DES COMPOSANTES DU SIGNAL FOURNI
  102. * (TUU/TUMU/UTU/UTUM IGNORERONT 'LX' DONC INUTILE DE LA FILTRER ICI)
  103. CALL LIROBJ('LISTMOTS',LCOMP,0,IRET)
  104. IF (IRET.NE.0) THEN
  105. SEGACT,LCOMP
  106. NCOMP=LCOMP.MOTS(/2)
  107. IF (NCOMP.EQ.0) THEN
  108. MOTERR(1:8)='LISTMOTS'
  109. CALL ERREUR(1027)
  110. RETURN
  111. ENDIF
  112. MLCHP1=ILCHP1
  113. SEGACT,MLCHP1
  114. N1=NCH
  115. SEGINI,MLCHPO
  116. DO ICH=1,NCH
  117. ICHP1=MLCHP1.ICHPOI(ICH)
  118. ICHP2=0
  119. DO ICO=1,NCOMP
  120. CHA4=LCOMP.MOTS(ICO)
  121. CALL EXCOPP(ICHP1,CHA4,NIFOUR,ICHP3,CHA4,NIFOUR,0)
  122. IF (IERR.NE.0) RETURN
  123. IF (ICHP2.EQ.0) THEN
  124. ICHP2=ICHP3
  125. ELSE
  126. CALL ADCHPO(ICHP2,ICHP3,ICHP2,1D0,1D0)
  127. IF (IERR.NE.0) RETURN
  128. ENDIF
  129. ENDDO
  130. ICHPOI(ICH)=ICHP2
  131. ENDDO
  132. SEGDES,MLCHP1
  133. ILCHP1=MLCHPO
  134. ENDIF
  135. *
  136. *
  137. * +---------------------------------------------------------------+
  138. * | M E T H O D E D E C A L C U L |
  139. * +---------------------------------------------------------------+
  140. *
  141. * MOT-CLE "SNAPSHOTS" OU "CLASSIQUE"
  142. * (LES 4 PREMIERS CARACTERES SUFFISENT)
  143. CALL LIRCHA(CHA4,0,IRET)
  144. IF (IRET.EQ.0) GOTO 992
  145. CALL CHRMOT(MMET,NMET,CHA4,IMET)
  146. IF (IMET.EQ.0) GOTO 992
  147. *
  148. * MATRICE DE MASSE (OU DE RAIDEUR) UTILISEE LORS DE L'INTEGRATION
  149. * SUR LE MAILLAGE EN ELEMENTS FINIS
  150. CALL LIROBJ('RIGIDITE',IRIG1,0,IZRIG)
  151. * AUCUNE VERIFICATION N'EST FAITE CAR LE CAS GENERAL PEUT ETRE
  152. * TRAITE SANS PLANTAGE, MAIS THEORIQUEMENT ON ATTEND ICI PLUTOT
  153. * UNE MATRICE SYMETRIQUE DEFINIE POSITIVE
  154. *
  155. GOTO 10
  156. *
  157. 992 CONTINUE
  158. MOTERR(1:4)=CHA4
  159. WRITE(CHA8,FMT='("(",I1,"A5)")') NMET
  160. WRITE(MOTERR(5:40),FMT=CHA8) (MMET(I),I=1,NMET)
  161. CALL ERREUR(1052)
  162. RETURN
  163. *
  164. *
  165. * +---------------------------------------------------------------+
  166. * | N O M B R E D E M O D E S D E M A N D E S |
  167. * +---------------------------------------------------------------+
  168. *
  169. 10 CALL LIRENT(NBMOD,1,IRET)
  170. IF (IERR.NE.0) RETURN
  171. *
  172. IF (NBMOD.LE.0) THEN
  173. WRITE(IOIMP,*) 'Le nombre de modes doit etre strictement ',
  174. & 'positif'
  175. INTERR(1)=NBMOD
  176. CALL ERREUR(36)
  177. RETURN
  178. ELSEIF (IMET.EQ.1.AND.NBMOD.GT.NCH) THEN
  179. WRITE(IOIMP,*) "On demande plus de modes qu'il n'y a de ",
  180. & "snapshots"
  181. INTERR(1)=NBMOD
  182. CALL ERREUR(36)
  183. RETURN
  184. ENDIF
  185. *
  186. *
  187. * +---------------------------------------------------------------+
  188. * | O P T I O N " T B A S " |
  189. * +---------------------------------------------------------------+
  190. *
  191. CALL LIRCHA(CHA4,0,IZTBAS)
  192. IF (IZTBAS.EQ.0) GOTO 100
  193. *
  194. IF (CHA4.NE.'TBAS') THEN
  195. MOTERR(1:4)=CHA4
  196. MOTERR(5:40)='TBAS'
  197. CALL ERREUR(1052)
  198. RETURN
  199. ENDIF
  200. *
  201. * LECTURE EVENTUELLE D'UN MAILLAGE QUI SERA PLACE DANS LA TABLE
  202. IF (IZTBAS.NE.0) THEN
  203. CALL LIROBJ('MAILLAGE',IMAV1,0,IZMAV)
  204. ENDIF
  205. *
  206. *
  207. *
  208. *
  209. * +---------------------------------------------------------------+
  210. * | |
  211. * | M A T R I C E D E S C O R R E L A T I O N S |
  212. * | |
  213. * +---------------------------------------------------------------+
  214. *
  215. 100 CONTINUE
  216. *
  217. IF (IMET.EQ.1) THEN
  218. IF (IZRIG.EQ.0) THEN
  219. * POD "SNAPSHOTS" SANS MATRICE
  220. CALL TUU(ILCHP1,(1.D0/NCH),IRIG2)
  221. ELSE
  222. * POD "SNAPSHOTS" AVEC MATRICE
  223. CALL TUMU(ILCHP1,IRIG1,(1.D0/NCH),IRIG2)
  224. ENDIF
  225. IF (IERR.NE.0) RETURN
  226. ELSEIF (IMET.EQ.2) THEN
  227. IF (IZRIG.EQ.0) THEN
  228. * POD "CLASSIQUE" SANS MATRICE
  229. CALL UTU(ILCHP1,(1.D0/NCH),IRIG2)
  230. ELSE
  231. * POD "CLASSIQUE" AVEC MATRICE
  232. CALL UTUM(ILCHP1,IRIG1,(1.D0/NCH),IRIG2)
  233. ENDIF
  234. ENDIF
  235. *
  236. *
  237. *
  238. *
  239. * +---------------------------------------------------------------+
  240. * | |
  241. * | C A L C U L D E L A B A S E P O D |
  242. * | |
  243. * +---------------------------------------------------------------+
  244. *
  245. *
  246. * +---------------------------------------------------------------+
  247. * | E S T I M A T I O N D U S H I F T |
  248. * +---------------------------------------------------------------+
  249. * LA METHODE DE LA PUISSANCE PERMET D'OBTENIR RAPIDEMENT UNE BONNE
  250. * ESTIMATION DE LA PLUS GRANDE VALEUR PROPRE
  251. *
  252. * MCOP,MCOD = LISTMOTS CONTENANT LES COMPOSANTES PRIMALES ET DUALES
  253. CALL EXTR16(IRIG2,0,MCOP)
  254. IF (IERR.NE.0) RETURN
  255. CALL EXTR16(IRIG2,1,MCOD)
  256. IF (IERR.NE.0) RETURN
  257. *
  258. * ICHP1 = CHAMP UNITAIRE SUR LE SUPPORT DE LA MATRICE IRIG2
  259. CALL UNIFO1(IRIG2,1.,ICHP0)
  260. IF (IERR.NE.0) RETURN
  261. ICHP1=ICHP0
  262. *
  263. * XVAL1 = MAXI(ABS(ICHP1))
  264. CALL MAXIN1(ICHP1,0,' ',0,XVAL1,1,1)
  265. IF (IERR.NE.0) RETURN
  266. *
  267. * ICHP2 = ICHP1 / XVAL1
  268. CALL OPCHP1(ICHP1,2,2,I1,(1.D0/XVAL1),ICHP2,IRET)
  269. IF (IERR.NE.0) RETURN
  270. *
  271. * NITMAX=NOMBRE D'ITERATIONS MAXIMUM
  272. * RESMAX=VALEUR DU CRITERE DE CONVERGENCE
  273. NITMAX=10
  274. RESMAX=1.D-5
  275. DO I=1,NITMAX
  276. *
  277. * ICHP3 = IRIG2*ICHP2
  278. CALL MUCPRI(ICHP2,IRIG2,ICHP3)
  279. IF (IERR.NE.0) RETURN
  280. *
  281. * XVAL2 = MAXI(ABS(ICHP3))
  282. CALL MAXIN1(ICHP3,0,' ',0,XVAL2,1,1)
  283. IF (IERR.NE.0) RETURN
  284. *
  285. * ICHP4 = ICHP3 / XVAL2
  286. CALL OPCHP1(ICHP3,2,2,I1,(1.D0/XVAL2),ICHP4,IRET)
  287. IF (IERR.NE.0) RETURN
  288. *
  289. XRES1=ABS((XVAL2-XVAL1)/XVAL1)
  290. IF (XRES1.LT.RESMAX) GOTO 200
  291. *
  292. * PREPARATION DE L'ITERATION SUIVANTE
  293. CALL NOMC2(ICHP4,MCOD,MCOP,ICHP2)
  294. IF (IERR.NE.0) RETURN
  295. XVAL1=XVAL2
  296. *
  297. ENDDO
  298. 200 CONTINUE
  299. *
  300. XFREQ=0.5/XPI*(XVAL1**0.5)
  301. SHIFT=CMPLX(XFREQ,0.D0)
  302. *
  303. *
  304. * +---------------------------------------------------------------+
  305. * | R E S O L U T I O N D U S Y S T E M E M A T R I C I E L |
  306. * +---------------------------------------------------------------+
  307. *
  308. * DANS CAST3M, ON NE PEUT ACUTELLEMENT PAS CALCULER UN PROBLEME
  309. * AUX VALEURS PROPRES CLASSIQUE (AX-nX=0) ; PAR CONTRE ON SAIT
  310. * RESOUDRE SA FORME DITE GENERALISEE (KX-nMX=0)
  311. *
  312. * DETERMINATION DE LA SYMETRIE DE LA MATRICE DE "RAIDEUR" K
  313. * => NORMALEMENT, ELLE DOIT ETRE SYMETRIQUE DANS TOUS LES CAS SAUF
  314. * SI IMET=2 ET IZRIG=VRAI (POD "CLASSIQUE" AVEC MATRICE)
  315. MRIGID=IRIG2
  316. SEGACT,MRIGID
  317. ISYM2=IRIGEL(7,1)
  318. NRIGEL=IRIGEL(/2)
  319. DO I=2,NRIGEL
  320. IF (IRIGEL(7,I).NE.ISYM2) ISYM2=2
  321. ENDDO
  322. SEGDES,MRIGID
  323. *
  324. * CREATION D'UNE MATRICE "MASSE" M VALANT L'IDENTITE
  325. CALL KOPDIR(ICHP0,IMAS2)
  326. IF (IERR.NE.0) RETURN
  327. MRIGID=IMAS2
  328. SEGACT,MRIGID*MOD
  329. MTYMAT='MASSE'
  330. SEGDES,MRIGID
  331. *
  332. * RESOLUTION PROPREMENT DITE
  333. * => SUBROUTINE A CHOISIR PARMI : PROCHE, INTVAL, SIMULT, ARPACK
  334. JG=1
  335. SEGINI,MLREEL
  336. PROG(1)=XFREQ
  337. SEGDES,MLREEL
  338. SEGINI,MLENTI
  339. LECT(1)=NBMOD
  340. SEGDES,MLENTI
  341. CALL ARPACK(IRIG2,IMAS2,0,ISOLUT,SHIFT,NBMOD,'LM',ISYM2,0)
  342. IF (IERR.NE.0) RETURN
  343. *
  344. * ON RECUPERE LES DONNEES CONTENUES DANS L'OBJET SOLUTION UNE BONNE
  345. * FOIS POUR TOUTES
  346. MSOLUT=ISOLUT
  347. SEGACT,MSOLUT
  348. MSOLE1=MSOLIS(4)
  349. IF (MSOLE1.EQ.0) THEN
  350. NBSOL=0
  351. SEGINI,TMODE
  352. ELSE
  353. SEGACT,MSOLE1
  354. NBSOL=MSOLE1.ISOLEN(/1)
  355. IF (ISYM2.NE.0) NBSOL=NBSOL/2
  356. SEGINI,TMODE
  357. IF (NBSOL.NE.0) THEN
  358. MSOLE2=MSOLIS(5)
  359. SEGACT,MSOLE2
  360. DO ISOL=1,NBSOL
  361. IF (ISYM2.EQ.0) THEN
  362. IMOD(ISOL)=MSOLE2.ISOLEN(ISOL)
  363. MMODE=MSOLE1.ISOLEN(ISOL)
  364. SEGACT,MMODE
  365. XMOD(ISOL)=FMMODD(1)
  366. SEGDES,MMODE
  367. ELSE
  368. * ON VERIFIE QUE LA FREQUENCE PROPRE IMAGINAIRE EST
  369. * BIEN NULLE, SINON...
  370. MMODE=MSOLE1.ISOLEN(2*ISOL)
  371. SEGACT,MMODE
  372. IF (FMMODD(1).NE.0) THEN
  373. WRITE(IOIMP,*) 'Les modes POD sont complexes'
  374. CALL ERREUR(21)
  375. RETURN
  376. ENDIF
  377. SEGDES,MMODE
  378.  
  379. ISOL1=2*ISOL-1
  380. IMOD(ISOL)=MSOLE2.ISOLEN(ISOL1)
  381. MMODE=MSOLE1.ISOLEN(ISOL1)
  382. SEGACT,MMODE
  383. XMOD(ISOL)=FMMODD(1)
  384. SEGDES,MMODE
  385. ENDIF
  386. ENDDO
  387. SEGDES,MSOLE2
  388. ENDIF
  389. SEGDES,MSOLE1
  390. ENDIF
  391. SEGDES,MSOLUT
  392. *
  393. *
  394. * +---------------------------------------------------------------+
  395. * | C O N S T R U C T I O N D E S P O D S N A P S H O T S |
  396. * +---------------------------------------------------------------+
  397. *
  398. IF (IMET.EQ.1.AND.NBSOL.NE.0) THEN
  399. *
  400. * ON RECOPIE LES SNAPSHOTS DANS LE SEGMENT TICHPO
  401. SEGINI,TICHPO,TXCOEF
  402. MLCHPO=ILCHP1
  403. SEGACT,MLCHPO
  404. DO K=1,NCH
  405. ICHPO(K)=ICHPOI(K)
  406. ENDDO
  407. IF (IPRO.EQ.1.OR.IPRO.EQ.4) THEN
  408. SEGDES,MLCHPO
  409. ELSEIF (IPRO.EQ.2.OR.IPRO.EQ.3) THEN
  410. SEGSUP,MLCHPO
  411. ENDIF
  412. *
  413. * MAILLAGE SUPER-ELEMENT DE LA MATRICE DES CORRELATIONS
  414. MRIGID=IRIG2
  415. SEGACT,MRIGID
  416. IPT2=IRIGEL(1,1)
  417. SEGDES,MRIGID
  418. SEGACT,IPT2
  419. IF (IPT2.NUM(/1).NE.NCH) THEN
  420. CALL ERREUR(223)
  421. RETURN
  422. ENDIF
  423. *
  424. * ON RECONSTRUIT LE I-EME MODE POD EN FAISANT LA COMBINAISON
  425. * LINEAIRE DES COEFFICIENTS DU I-EME VECTEUR PROPRE AVEC LES
  426. * CHAMPS DU LISTCHPO CONTENANT LE SIGNAL (LES "SNAPSHOTS")
  427. SEGACT,MSOLE2*MOD
  428. DO ISOL=1,NBSOL
  429. MCHPO1=IMOD(ISOL)
  430. SEGACT,MCHPO1
  431. MSOUP1=MCHPO1.IPCHP(1)
  432. SEGACT,MSOUP1
  433. IPT1=MSOUP1.IGEOC
  434. MPOVA1=MSOUP1.IPOVAL
  435. SEGACT,IPT1,MPOVA1
  436. IF (IPT1.NUM(/2).NE.NCH) THEN
  437. CALL ERREUR(223)
  438. RETURN
  439. ENDIF
  440. DO 300 I=1,NCH
  441. * ON CHERCHE A QUEL CHPOINT DU LISTCHPO ON DOIT ASSOCIER
  442. * LE I-EME NOEUD DU SUPPORT DU VECTEUR PROPRE
  443. DO J=1,NCH
  444. IF (IPT1.NUM(1,I).EQ.IPT2.NUM(J,1)) THEN
  445. XCOEF(J)=MPOVA1.VPOCHA(I,1)
  446. GOTO 300
  447. ENDIF
  448. ENDDO
  449. CALL ERREUR(18)
  450. RETURN
  451. 300 CONTINUE
  452. SEGDES,MPOVA1,IPT1,MSOUP1,MCHPO1
  453. *
  454. * ON FAIT LA COMBINAISON LINEAIRE PUIS ON ENLEVE LES
  455. * MULTIPLICATEURS DE LAGRANGE
  456. CALL COMBIL(TICHPO,TXCOEF,NCH,ICHP1)
  457. IF (IERR.NE.0) RETURN
  458. MCHPOI=ICHP1
  459. SEGACT,MCHPOI*MOD
  460. NBSOU=IPCHP(/1)
  461. NAT=JATTRI(/1)
  462. NSOUPO=0
  463. DO I=1,NBSOU
  464. MSOUPO=IPCHP(I)
  465. SEGACT,MSOUPO
  466. IF (NOCOMP(1).EQ.'LX') GOTO 310
  467. NSOUPO=NSOUPO+1
  468. IPCHP(NSOUPO)=MSOUPO
  469. 310 CONTINUE
  470. SEGDES,MSOUPO
  471. ENDDO
  472. IF (NSOUPO.NE.NBSOU) SEGADJ,MCHPOI
  473. SEGDES,MCHPOI
  474. *
  475. * ON NORMALISE LES MODES (NORME INFINIE)
  476. CALL MAXIM1(ICHP1,0,' ',0,XMAX1)
  477. IF (IERR.NE.0) RETURN
  478. IF (XMAX1.NE.0.D0) THEN
  479. CALL NORMA1(ICHP1,0,' ',ICHP2)
  480. IF (IERR.NE.0) RETURN
  481. CALL DTCHPO(ICHP1)
  482. ICHP1=ICHP2
  483. ENDIF
  484. *
  485. * ON MODIFIE DIRECTEMENT LE SEGMENT TMODE (ET AUSSI L'OBJET
  486. * SOLUTION, POUR L'OPTION "TBAS") EN Y INSERANT LE MODE POD
  487. IMOD(ISOL)=ICHP1
  488. MSOLE2.ISOLEN(ISOL)=ICHP1
  489. ENDDO
  490. *
  491. SEGDES,MSOLE2
  492. SEGDES,IPT2
  493. SEGSUP,TICHPO,TXCOEF
  494. *
  495. ENDIF
  496. *
  497. *
  498. *
  499. *
  500. * +---------------------------------------------------------------+
  501. * | |
  502. * | M I S E E N F O R M E D E S R E S U L T A T S |
  503. * | |
  504. * +---------------------------------------------------------------+
  505. *
  506. *
  507. * SOUS FORME D'UN OBJET TABLE
  508. * ***************************
  509. IF (IZTBAS.NE.0) THEN
  510. *
  511. * APPEL A CRTBAS OU CCTBAS POUR TRANSFORMER L'OBJET SOLUTION
  512. * EN OBJET TABLE
  513. IF (ISYM2.EQ.0) THEN
  514. CALL CRTBAS(ISOLUT,IMAS2)
  515. IF (IERR.NE.0) RETURN
  516. ELSE
  517. CALL CCTBAS(ISOLUT,IMAS2)
  518. IF (IERR.NE.0) RETURN
  519. ENDIF
  520. CALL LIROBJ('TABLE',MTABLE,1,IRET)
  521. IF (IERR.NE.0) RETURN
  522. CHA8='TABLE'
  523. CALL ACMO(MTABLE,'MODES',CHA8,ITAB1)
  524. IF (IERR.NE.0) RETURN
  525. *
  526. * 1) SI LA MATRICE EST NON SYMETRIQUE, ON A ETE OBLIGE D'APPELER
  527. * CCTBAS ET ON DOIT MAINTENANT ENLEVER LA PARTIE IMAGINAIRE
  528. * 2) ON RAJOUTE UN INDICE "VALEUR_PROPRE" EN FIN DE TABLE
  529. CALL QUERAN(II1,'MOT',13,XVAL,'VALEUR_PROPRE',ZLOGI,IOBJ)
  530. IF (NBESC.NE.0) SEGACT,IPILOC
  531. DO ISOL=1,NBSOL
  532. * MTAB2 = SOUS-TABLE ASSOCIEE AU MODE NUMERO ISOL
  533. CALL ACCTAB(ITAB1,'ENTIER',ISOL,0.D0,'MOT',.TRUE.,0,
  534. & 'TABLE',IVAL,XVAL,CHA8,ZLOGI,MTAB2)
  535. IF (IERR.NE.0) RETURN
  536. SEGACT,MTAB2*MOD
  537. MLOTA=MTAB2.MLOTAB
  538. M=0
  539. * BOUCLE SUR LES INDICES DE MTAB2
  540. DO 410 I=1,MLOTA
  541. *
  542. * VALEUR DU I-EME INDICE (TOUJOURS DE TYPE MOT)
  543. CHA8=MTAB2.MTABTV(I)
  544. IMO1=IPCHAR(MTAB2.MTABII(I))
  545. IMO2=IPCHAR(MTAB2.MTABII(I)+1)
  546. ILON=IMO2-IMO1
  547. CHA40(1:ILON)=ICHARA(IMO1:IMO1+ILON-1)
  548. *
  549. IF (ISYM2.NE.0) THEN
  550. *
  551. * INDICE ASSOCIE A LA PARTIE IMAGINAIRE => ON SAUTE
  552. J1=INDEX(CHA40(1:ILON),'_IMAG')
  553. IF (J1.NE.0) GOTO 410
  554. *
  555. * INDICE ASSOCIE A LA PARTIE REELLE => ON RENOMME
  556. J2=INDEX(CHA40(1:ILON),'_REEL')
  557. IF (J2.NE.0) THEN
  558. IL=J2-1
  559. CHB40=CHA40(1:IL)
  560. CALL QUERAN(II2,'MOT',IL,XVAL,CHB40,ZLOGI,IOBJ)
  561. MTAB2.MTABII(I)=II2
  562. ENDIF
  563. *
  564. * DECALAGE DES DONNEES DE MTAB2 PUISQUE LES INDICES
  565. * ASSOCIES A LA PARTIE IMAGINAIRE NE SONT PLUS LA
  566. M=M+1
  567. IF (M.NE.I) THEN
  568. MTAB2.MTABTI(M)=MTAB2.MTABTI(I)
  569. MTAB2.MTABTV(M)=MTAB2.MTABTV(I)
  570. MTAB2.RMTABI(M)=MTAB2.RMTABI(I)
  571. MTAB2.MTABII(M)=MTAB2.MTABII(I)
  572. MTAB2.MTABIV(M)=MTAB2.MTABIV(I)
  573. MTAB2.RMTABV(M)=MTAB2.RMTABV(I)
  574. ENDIF
  575. *
  576. ELSE
  577. M=M+1
  578. ENDIF
  579. *
  580. * ON MEMORISE LA FREQUENCE DU MODE
  581. IF (CHA40(1:9).EQ.'FREQUENCE') XFRQ=MTAB2.RMTABV(I)
  582. *
  583. 410 CONTINUE
  584. *
  585. * ON AJOUTE UN INDICE "VALEUR_PROPRE" EN FIN DE TABLE
  586. XVAL=(2.D0*XPI*XFRQ)**2
  587. M=M+1
  588. MTAB2.MLOTAB=M
  589. SEGADJ,MTAB2
  590. MTAB2.MTABTI(M)='MOT'
  591. MTAB2.MTABTV(M)='FLOTTANT'
  592. MTAB2.MTABII(M)=II1
  593. MTAB2.RMTABV(M)=XVAL
  594. *
  595. SEGDES,MTAB2
  596. ENDDO
  597. IF (NBESC.NE.0) SEGDES,IPILOC
  598. *
  599. * ON ORDONNE LES MODES PAR VALEUR PROPRE DECROISSANTE...
  600. NTRA=NBSOL
  601. SEGINI,TRAV1,TRAV2
  602. DO ISOL=1,NBSOL
  603. CALL ACCTAB(ITAB1,'ENTIER',ISOL,0.D0,'MOT',.TRUE.,0,
  604. & 'TABLE',IVAL,XVAL,CHA8,ZLOGI,ITAB2)
  605. IF (IERR.NE.0) RETURN
  606. *
  607. * ON NE PEUT PAS UTILISER XMOD(ISOL) CAR CRTBAS/CCTBAS A
  608. * MODIFIE L'ORDRE DES MODES PAR RAPPORT A L'OBJET SOLUTION
  609. CALL ACCTAB(ITAB2,'MOT',0,0.D0,'FREQUENCE',.TRUE.,0,
  610. & 'FLOTTANT',IVAL,XVAL,CHA8,ZLOGI,IOBJ)
  611. IF (IERR.NE.0) RETURN
  612. *
  613. IMOD(ISOL)=ITAB2
  614. XORD(ISOL)=XVAL
  615. IORD(ISOL)=ISOL
  616. ENDDO
  617. CALL ORDM03(XORD(1),IORD(1),NTRA,XTRA(1),ITRA(1),.FALSE.)
  618. *
  619. * ...PUIS ON MET A JOUR LA TABLE DES MODES
  620. DO ISOL=1,NBSOL
  621. ITAB2=IMOD(IORD(ISOL))
  622. CALL ECCTAB(ITAB1,'ENTIER',ISOL,0.D0,'MOT',.TRUE.,0,
  623. & 'TABLE',IVAL,XVAL,CHA8,ZLOGI,ITAB2)
  624. CALL ECCTAB(ITAB2,'MOT',ISOL,0.D0,'NUMERO_MODE',.TRUE.,0,
  625. & 'ENTIER',ISOL,XVAL,CHA8,ZLOGI,IOBJ)
  626. ENDDO
  627. SEGSUP,TRAV1,TRAV2
  628. *
  629. * ENFIN, ON MET A JOUR LE MAILLAGE CONTENU DANS LA TABLE
  630. IF (IZMAV.EQ.0) THEN
  631. NBNN=1
  632. NBELEM=0
  633. NBSOUS=0
  634. NBREF=0
  635. SEGINI,MELEME
  636. ITYPEL=1
  637. IMAV1=MELEME
  638. SEGDES,MELEME
  639. ENDIF
  640. CALL ECCTAB(ITAB1,'MOT',ISOL,0.D0,'MAILLAGE',.TRUE.,0,
  641. & 'MAILLAGE',ISOL,XVAL,CHA8,ZLOGI,IMAV1)
  642. *
  643. *
  644. CALL ECROBJ('TABLE',MTABLE)
  645. *
  646. *
  647. * SOUS FORME DE DEUX OBJETS LISTCHPO ET LISTREEL
  648. * **********************************************
  649. ELSE
  650. *
  651. IF (NBSOL.NE.0) THEN
  652. *
  653. * ON ORDONNE LES MODES PAR VALEUR PROPRE DECROISSANTE...
  654. NTRA=NBSOL
  655. SEGINI,TRAV1,TRAV2
  656. DO ISOL=1,NBSOL
  657. XORD(ISOL)=XMOD(ISOL)
  658. IORD(ISOL)=ISOL
  659. ENDDO
  660. CALL ORDM03(XORD(1),IORD(1),NTRA,XTRA(1),ITRA(1),.FALSE.)
  661. *
  662. * ...PUIS ON REMPLIT LE LISTCHPO ET LE LISTREEL
  663. N1=NBSOL
  664. JG=NBSOL
  665. SEGINI,MLCHPO,MLREEL
  666. DO ISOL=1,NBSOL
  667. ISOL1=IORD(ISOL)
  668. PROG(ISOL)=XMOD(ISOL1)
  669. ICHPOI(ISOL)=IMOD(ISOL1)
  670. ENDDO
  671. *
  672. SEGSUP,TRAV1,TRAV2
  673. *
  674. ELSE
  675. N1=0
  676. JG=0
  677. SEGINI,MLCHPO,MLREEL
  678. ENDIF
  679. *
  680. SEGDES,MLCHPO,MLREEL
  681. *
  682. *
  683. CALL ECROBJ('LISTREEL',MLREEL)
  684. CALL ECROBJ('LISTCHPO',MLCHPO)
  685. *
  686. ENDIF
  687. *
  688. SEGSUP,TMODE
  689. *
  690. RETURN
  691. *
  692. END
  693. *
  694. *
  695.  
  696.  
  697.  

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