Télécharger la plaquette Cast3M


fr en

Télécharger vibrat.eso

Retour à la liste

Numérotation des lignes : 

vibrat

  1. C VIBRAT    SOURCE    BP208322  21/03/17    21:15:10     10921          
  2.       SUBROUTINE VIBRAT
  3. ************************************************************************
  4. *
  5. *                             V I B R A T
  6. *                             -----------
  7. *
  8. *            SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "VIBRation"
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. *     CALCUL DE MODES PROPRES.
  14. *
  15. * PHRASE D'APPEL (EN GIBIANE):
  16. * ----------------------------
  17. *
  18. *     ..... = VIBRATION | PROCHE .....     | ;
  19. *                       | INTERVALLE ..... |
  20. *                       | SIMULTANE .....  |
  21. *                       | IRAM .....       |
  22. *
  23. *     VOIR LES DETAILS DANS LES SOUS-PROGRAMMES ASSOCIES AUX OPTIONS
  24. *     "PROCHE", "INTERVALLE", ETC...
  25. *
  26. * SOUS-PROGRAMMES APPELES:
  27. * ------------------------
  28. *
  29. *     INTVAL, LIRMOT, PROCHE, SIMULT, ARPACK
  30. *
  31. *
  32. * CREATION et MODIFICATION:
  33. * ------------------------
  34. *     PASCAL MANIGOT, 13 NOVEMBRE 1984: creation
  35. *     PASCAL BOUDA, 24 JUIN 2015: AJOUT DE L'OPTION IRAM
  36. *     BP, 2019-09-28: LIMAGE=VRAI PAR DEFAUT
  37. *     BP, 2019-09-28: LOG1=VRAI PAR DEFAUT
  38. *     EN PREVISION SUPPRESSION DES OBJETS SOLUTIONS
  39. *     PB 2020-12: TRAVAIL SUR LES MATRICES CONDENSEES + 
  40. *     MENAGE (TRI DES RIGIDITES, TRAITEMENT DE L'OBJET SOLUTION)
  41. *
  42. ************************************************************************
  43. *
  44.       IMPLICIT INTEGER(I-N)
  45.       IMPLICIT REAL*8 (A-H,O-Z)
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. *-INC SMSOLUT
  50. -INC SMCHPOI
  51. -INC SMRIGID
  52. -INC SMTABLE
  53. -INC CCHAMP
  54.  
  55.       SEGMENT IDEMEM(0)
  56.       SEGMENT IDEME0(IDEMEM(/1),2)
  57.       SEGMENT IDEME1(IDEMEM(/1),2)
  58.  
  59.       COMMON/CITINV/ NBITER,IACCEL,NUMAC,IPX2,IPX0,IPX1,IPBX1,
  60.      C IBBX1,IBBX2,ITPRO,DIFREL
  61. *
  62.       PARAMETER (NBRMOT = 10)
  63.       PARAMETER (NBIMOT = 9)          
  64.  
  65.       CHARACTER*4 LISMOT(NBRMOT)
  66.       CHARACTER*8 letyp,charre
  67.       CHARACTER*2 LIRAM(NBIMOT)
  68.  
  69.       COMPLEX*16 SHIFT
  70.       CHARACTER*2 SOLU
  71.  
  72.  
  73.       LOGICAL LOG1, LIMAGE, LMULT,boolin, LVIBC
  74. *
  75.       DATA LISMOT/'PROC','INTE','SIMU','IRAM',
  76.      &                   'IMPR','BASS','HAUT','TBAS','MULT','SOLU'/
  77.  
  78. *     LISTE SPECIFIQUE IRAM
  79.       DATA LIRAM/'LM','SM','LR','SR','LI','SI','LA','SA','BE'/
  80.  
  81.  
  82. ************************************************************************
  83. *     INITIALISATIONS et VERIFICATION
  84. ************************************************************************
  85. *
  86.       IBASS  = 0
  87.       IHAUT  = 0
  88.       NOPT   = 0
  89.       ivalin = 0
  90.       LOG1 = .TRUE.
  91.       LMULT = .FALSE.
  92.       LIMAGE=  .TRUE.
  93.       NIMP=IIMPI
  94.       ICODE = 0
  95.       NBMOT = NBRMOT
  96.       NBMOTI= NBIMOT
  97.       NBMO=0
  98.       SHIFT=CMPLX(0.D0,0.D0)
  99.  
  100.  
  101. c *     verification de l'option de calcul des deformations
  102. c       IF(MEPSIL.NE.1) THEN
  103. c         CALL ERREUR(1037)
  104. c         RETURN
  105. c       ENDIF
  106. cbp, 2020-12-10 : ci dessus n'a plus lieu d'etre car SIGSOL travaille 
  107. c                 toujours en hypothese de deformations lineaires
  108. *
  109. ************************************************************************
  110. *     LECTURE DES MOTS-CLE ET DONNEES SPECIFIQUES ASSOCIEES
  111. ************************************************************************
  112.  
  113. ***** 1ere liste de mots-cles ******************************************
  114.       DO 10 I=1,5
  115.  
  116.       CALL LIRMOT (LISMOT,NBMOT,NUMLIS,ICODE)
  117.       IF (IERR .NE. 0) RETURN
  118.       IF (NUMLIS.EQ.0) GOTO 10
  119.  
  120. c    -lecture effective de 'PROC','INTE','SIMU' ou 'IRAM'
  121.       IF (NUMLIS.LE.4) THEN
  122.         IF (NUMLIS.EQ.1) THEN
  123.            CALL LIROBJ ('LISTREEL',IPFREQ,1,IRETOU)
  124.            IF (IERR.NE.0) RETURN
  125.            IPNMOD = 0
  126.            CALL LIROBJ ( 'LISTENTI', IPNMOD, 0, IRETOU )
  127.            IF (IERR .NE. 0) RETURN
  128.         ENDIF
  129.         IF (NUMLIS.EQ.2) THEN
  130.            CALL LIRREE(XINT1,1,IRETOU)
  131.            IF (IERR.NE.0) RETURN
  132.            CALL LIRREE(XINT2,1,IRETOU)
  133.            IF(IERR.NE.0) RETURN
  134.         ENDIF
  135.         IF (NUMLIS.GE.3) THEN
  136.            CALL LIRREE(XINT1,1,IRETOU)
  137.            IF (IERR.NE.0) RETURN
  138.            CALL LIRENT (IBASS,1,IRETOU)
  139.            IF (IERR.NE.0) RETURN
  140.         ENDIF
  141.         NOPT=NUMLIS
  142.         GOTO 10
  143.       ENDIF
  144.  
  145. c    -autres options
  146.       IF (NUMLIS.EQ.5) THEN
  147. ***     IIMPI=2
  148.         CALL GINT2
  149.       ENDIF
  150.  
  151.       IF (NUMLIS.EQ.6)  CALL LIRENT (IBASS,1,IRETOU)
  152.       IF(IERR.NE.0) RETURN
  153.       IF (NUMLIS.EQ.7)  CALL LIRENT(IHAUT,1,IRETOU)
  154.  
  155.       IF(IERR.NE.0) RETURN
  156. cbp 2017-09-28      IF (NUMLIS.EQ.8) LOG1 = .TRUE.
  157.       IF (NUMLIS.EQ.8) THEN
  158.         MOTERR(1:12)='mot-cle TBAS'
  159.         MOTERR(13:40)=' '
  160.         CALL ERREUR(1070)
  161. c       WARNING : mot-cle TBAS soon obsolete
  162.       ENDIF
  163.       IF (NUMLIS.EQ.10) THEN
  164.         LOG1  = .FALSE.
  165.         MOTERR(1:14)='OBJET SOLUTION'
  166.         MOTERR(15:40)=' '
  167.         CALL ERREUR(1070)
  168. c       WARNING : OBJET SOLUTION soon obsolete
  169.       ENDIF
  170.       IF (NUMLIS.EQ.9) LMULT = .TRUE.
  171.  
  172. 10    CONTINUE
  173.  
  174.  
  175. ***** MOTS CLES SPECIFIQUES IRAM *****************
  176.       IF (NOPT .EQ. 4) THEN
  177.  
  178. c       on recupere shift Re + i Im et nbmo a calculer
  179.         X=XINT1
  180.         Y=0.D0
  181.         CALL LIRREE(Y,0,IRETOU)
  182.         SHIFT=CMPLX(X,Y)
  183.         NBMO=IBASS
  184.  
  185.         SOLU='LM'
  186.         CALL LIRMOT (LIRAM,NBMOTI,NUMIRA,ICODE)
  187.         IF (IERR .NE. 0) RETURN
  188.         IF (NUMIRA.NE.0) SOLU=LIRAM(NUMIRA)
  189.  
  190.       ENDIF
  191.  
  192.  
  193. ************************************************************************
  194. *     LECTURE DES RIGIDITES (sans se soucier de leur type)
  195. ************************************************************************
  196.  
  197.       CALL LIROBJ('RIGIDITE',IPRIG0,1,IRETOU)
  198.       IF(IERR.NE.0) RETURN
  199.  
  200.       CALL LIROBJ ('RIGIDITE',IPMAS0,1,IRETOU)
  201.       IF (IERR.NE.0) RETURN
  202.  
  203.       CALL LIROBJ ('RIGIDITE',IPAMO0,0,IRETOU)
  204.       IF (IERR.NE.0) RETURN
  205.  
  206. ** pb dec20: le travail desormais uniformise en amont des options
  207. **On trie les rigidites lues
  208.       IF (IRETOU .EQ. 0) THEN
  209. **deux matrices lues
  210.          CALL WHICH1(IPRIG0,IPMAS0,IPRIG1,IPMAS1)
  211.          IPRIG0=IPRIG1
  212.          IPMAS0=IPMAS1
  213.          IPAMO0=0
  214.       ELSEIF (IRETOU .EQ. 1) THEN
  215. **trois matrices
  216.          CALL QZTRIR (IPMAS0,IPRIG0,IPAMO0)
  217.       ENDIF    
  218.       IF (IERR.NE.0) RETURN     
  219. *     Lecture d'un logique optionnel pour savoir que faire si (2pi*w)^2
  220. *     est negatif (faux --> on renvoie |w|, vrai --> on renvoie -|w|
  221. *     car pas d'imaginaire)
  222.       CALL LIRLOG(LIMAGE,0,IRETOU)
  223.       IF (IRETOU.NE.0) THEN
  224. *       avertissement : syntaxe bientot obsolete
  225.         MOTERR(1:40)='use of a logical'
  226.         CALL ERREUR(1070)
  227.       ENDIF
  228.  
  229. ***pb dec20: devenu caduque (travail sur matrice condensee)   
  230. ****     dualisation des mult de Lagrange pour la matrice de sstype RIGI
  231. *      MRIGID=IPRIG0
  232. *      SEGINI,RI1=MRIGID
  233. *      SEGDES MRIGID
  234. *      MRIGID=RI1
  235. *      IMGEO2=0
  236. *      CALL DBBLX(MRIGID,LAGDUA)
  237. *      IMLAG=LAGDUA
  238. *      IPRIG2=MRIGID
  239. *      SEGDES MRIGID
  240.  
  241. ***************************
  242. *Condensation des matrices*
  243. ***************************
  244. * Chpoint primal "dummy" pour enregistrer l'elimination des composantes
  245.       CALL DECALE(IPRIG0,IPMAS0,1D0,IPINIT)
  246.       IF (IERR.NE.0) RETURN
  247.       CALL UNIFO1(IPINIT,0D0,IPCHPO)
  248.       IF (IERR.NE.0) RETURN
  249.       CALL MUCPRI(IPCHPO,IPINIT,IPCHP0)
  250.       IF (IERR.NE.0) RETURN
  251.       CALL DTCHPO(IPCHPO)
  252.       CALL DTRIGI(IPINIT)
  253.       IF (IERR.NE.0) RETURN
  254.  
  255.       SEGINI IDEMEM
  256.       IDEMEM(**)=IPCHP0
  257.       SEGINI IDEME0,IDEME1
  258.  
  259. *Condensation sur matrices copiees => MYMAT =  TEMPORAI
  260.       CALL RIGELI(IPRIG0,IPMAS0,IPAMO0,IPRIGI,IPMASS,IPAMOR,
  261.      &                                 IDEMEM,IDEME0,IDEME1,IELIM)
  262.       IF (IERR.NE.0) RETURN
  263. ************************************************************************
  264. *     APPEL DES ROUTINES SELON L'OPTION
  265. ************************************************************************
  266.  
  267. ***** PROCHE *****
  268.       IF (NOPT .EQ. 1) THEN
  269.          ITPRO=1
  270.          CALL PROCHE (IPSOLU,IPFREQ,IPMASS,IPRIGI,LIMAGE,
  271.      &                IPNMOD,MBASC,INSYM)
  272.  
  273.          IF (IERR.NE.0) RETURN
  274. c        TODO : debrancher le solveur non-symetrique de PROCHE
  275. ***** INTERVALLE *****
  276.       ELSE IF (NOPT .EQ. 2) THEN
  277.          ITPRO=0
  278.          INSYM=0
  279.          CALL INTVAL (IPSOLU,XINT1,XINT2,IBASS,IHAUT,
  280.      $                 LIMAGE,IPMASS,IPRIGI,LMULT)
  281.          IF (IERR.NE.0) RETURN
  282. ***** SIMULTANE *****
  283.       ELSE IF (NOPT .EQ. 3) THEN
  284.          ITPRO=0
  285.          INSYM=0
  286.          CALL SIMULT (IPSOLU,IPMASS,IPRIGI,LIMAGE,XINT1,IBASS)
  287.          IF (IERR.NE.0) RETURN
  288.  
  289. ***** IRAM *****
  290.       ELSE IF (NOPT .EQ. 4) THEN
  291.          CALL ARPACK (IPSOLU,IPMASS,IPRIGI,IPAMOR,SHIFT,
  292.      $                NBMO,SOLU,INSYM,LAGDUA)
  293.          IF (IERR.NE.0) RETURN
  294.  
  295. *pb dec20: suppression des goto pour uniformiser le canal de 
  296. *posttraitement        
  297. *        
  298. *        cas Hermitien/non-Hermitien
  299. *         IF (INSYM.EQ.0) THEN
  300. *          cas Hermitien --> modes Reels
  301. *           GOTO 901
  302. *        ELSE
  303. *          cas non-Hermitien --> modes Complexes
  304. *           GOTO 902
  305. *         ENDIF
  306.  
  307.       ELSE
  308.          CALL ERREUR (533)
  309.          RETURN
  310.       ENDIF
  311.  
  312. ************************************************************************
  313. *     POST TRAITEMENT DES RESULTATS
  314. ************************************************************************
  315.       IF (INSYM .EQ. 0) THEN
  316.          LVIBC=.FALSE.      
  317.       ELSE
  318.          LVIBC=.TRUE.
  319.       ENDIF
  320.  
  321. c NB: INSYM=0 si pb aux v.p. Hermitien (K et M Reels et symetriques)
  322. *bp,2019 : erreur si pb non symetrique, car debranche sauf pour IRAM
  323.       IF (NOPT .NE. 4 .AND. LVIBC) THEN
  324.         CALL ERREUR(969)
  325.         RETURN
  326.       ENDIF
  327.  
  328. *pb dec20: devenu caduque (travail sur matrice condensee)   
  329. c***** Appel a dbbcf pour dedualiser les modes (chpoints) *****                                  
  330. *      MSOLUT=IPSOLU
  331. *      SEGACT MSOLUT*MOD                
  332. *      DO ILX=1,MSOLIT(/1)
  333. *         IF (MSOLIT(ILX).EQ.2) THEN
  334. *            MSOLEN=MSOLIS(ILX)          
  335. *            SEGACT MSOLEN*MOD       
  336. *            DO ISO=1,ISOLEN(/1)
  337. *               MCHPOI=ISOLEN(ISO)          
  338. *               SEGACT MCHPOI*MOD
  339. *               IF (LAGDUA.NE.0) CALL DBBCF(MCHPOI,LAGDUA)
  340. *               ISOLEN(ISO)=MCHPOI
  341. *               SEGDES MCHPOI
  342. *            ENDDO
  343. *            SEGDES MSOLEN
  344. *         ENDIF
  345. *      ENDDO
  346. *      SEGDES MSOLUT
  347.  
  348. **pb dev20: dedualisation des mult de lagrange substituee par une 
  349. **reconstruction des modes necessaire suite a la condensation
  350.       CALL VIRECO(LVIBC,IPSOLU,IPRIGI,IPMASS,IPAMOR,IELIM,IDEME0,IDEME1)
  351.       IF (IERR.NE.0) RETURN
  352.  
  353. *bp,2019      IF (insym.eq.0) then
  354. *        dedualisation de la solution
  355. *         msolut=ipsolu
  356. *         segact msolut*mod
  357. *         do 210 ilx=1,msolit(/1)
  358. *          if (msolit(ilx).eq.2) then
  359. *          msolen=msolis(ilx)
  360. *          segact msolen*mod
  361. *          do 200 iso=1,isolen(/1)
  362. *           mchpoi=isolen(iso)
  363. *           segact mchpoi*mod
  364. *           if (lagdua.ne.0) call dbbcf(mchpoi,lagdua)
  365. *           isolen(iso)=mchpoi
  366. * 200      continue
  367. *          endif
  368. * 210     continue
  369.  
  370. *bp,2019      ELSE
  371. c        if (lagdua.ne.0)  then
  372. c          mtable=mbasc
  373. c          segact mtable
  374. c          call acctab(mbasc,'MOT     ',iva,xvalin,'MODES',boolin,iobin,
  375. c      $              'TABLE  ',ivalre,xvalre,charre,boolin,mtab1)
  376. c          do 250 i=1,10000
  377. c           letyp=' '
  378. c           call acctab (mtab1,'ENTIER  ',i,xva,charre,boolin,iobin,
  379. c      $           letyp,ivalre,xvalre,charre,boolin,mtab2)
  380. c           if(letyp.ne.'TABLE   ') go to 251
  381. c            letyp=' '
  382. c            call acctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_REELLE',
  383. c      $   boolin,iobin,letyp,ivalre,xvalre,charre,boolin,iobre)
  384. c          if(letyp.eq.'CHPOINT') then
  385. c             mchpoi=iobre
  386. c             segact mchpoi*mod
  387. c             call dbbcf(mchpoi,lagdua)
  388. c             call ecctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_REELLE',
  389. c      $      boolin,iobin,letyp,ivalre,xvalre,charre,boolin,mchpoi)
  390. c          else
  391. c           call erreur(5)
  392. c           return
  393. c          endif
  394. c
  395. c           letyp=' '
  396. c           call acctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_IMAGINAIRE',
  397. c      $   boolin,iobin,letyp,ivalre,xvalre,charre,boolin,iobre)
  398. c          if(letyp.eq.' ')go to 250
  399. c             mchpoi=iobre
  400. c             segact mchpoi*mod
  401. c             call dbbcf(mchpoi,lagdua)
  402. c             call ecctab(mtab2,'MOT',ivalin,xva,'DEFORMEE_MODALE_IMAG',
  403. c      $      boolin,iobin,letyp,ivalre,xvalre,charre,boolin,mchpoi)
  404. c   250    continue
  405. c        endif
  406. c   251  continue
  407. c       ENDIF
  408.  
  409. *pb dev20 suppression des goto pour uniformiser le canal
  410. *bp,2019      IF (INSYM .EQ. 0) THEN
  411.       IF (INSYM .EQ. 0) THEN
  412. ***** CREATION D'UNE BASE MODALE REELLE *****
  413. c901   CONTINUE
  414.          IF (LOG1) THEN
  415.           CALL CRTBAS (IPSOLU,IPMAS0)
  416.           IF (IERR.NE.0) RETURN
  417. C          CALL DESOLU (IPSOLU)
  418.           IF (IERR.NE.0) RETURN
  419.          ELSE
  420.           CALL ECROBJ ('SOLUTION',IPSOLU)
  421.          ENDIF
  422. *bp,2019      ELSE
  423. *bp,2019          CALL LIROBJ('CHPOINT', IPOINT, 0, IRETOU)
  424. *bp,2019          CALL ECROBJ('TABLE', MBASC)
  425. *bp,2019      ENDIF
  426.  
  427. C      GOTO 100
  428.       ELSE
  429. ***** CREATION D'UNE BASE MODALE COMPLEXE (IRAM SEULEMENT) *****
  430. c902   CONTINUE
  431.          IF (LOG1) THEN
  432.            CALL CCTBAS (IPSOLU,IPMAS0)
  433.            IF (IERR.NE.0) RETURN
  434.            CALL DESOLU (IPSOLU)
  435.            IF (IERR.NE.0) RETURN
  436.          ELSE
  437. *       ce cas ci-apres n'est pas terrible...
  438.            CALL ECROBJ ('SOLUTION',IPSOLU)
  439.          ENDIF
  440. *
  441.       ENDIF
  442.  
  443. *menage sur les matrices copiees      
  444.       IF (IPRIGI.NE.0) CALL DTRIGI(IPRIGI)
  445.       IF (IPMASS.NE.0) CALL DTRIGI(IPMASS)
  446.       IF (IPAMOR.NE.0) CALL DTRIGI(IPAMOR)
  447.  
  448. ************************************************************************
  449. *     FIN NORMALE
  450. ************************************************************************
  451. C100   CONTINUE      
  452.       IIMPI=NIMP
  453.       CALL GINT2
  454.  
  455.       END
  456.  
  457.  
  458.  

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