Télécharger la plaquette Cast3M


fr en

Télécharger hbmsor.eso

Retour à la liste

Numérotation des lignes : 

hbmsor

  1. C HBMSOR    SOURCE    OF166741  26/05/11    21:15:15     12538          
  2.  
  3.       SUBROUTINE HBMSOR(KSORT,KPREF,NOTYPS,NHBM)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10.  
  11. -INC SMLREEL
  12. -INC SMLENTI
  13. -INC SMLMOTS
  14. -INC SMTABLE
  15.       POINTEUR MTAB4.MTABLE,MTAB5.MTABLE,MTAB6.MTABLE
  16.  
  17. -INC TMDYNC
  18.  
  19.       INTEGER NOTYPS
  20.       LOGICAL ZPLUS
  21.  
  22. C Fonctions BLAS/LAPACK
  23.        REAL*8    DNRM2
  24.        EXTERNAL  DNRM2
  25.  
  26. *     recup
  27.       PSORT=KSORT
  28.       MPREF=KPREF
  29.       NT1  = QSAVE(/1)
  30.       NPAS = QSAVE(/2)
  31.       NA1x2= LSAVE(/2)
  32.       NA1  = NA1x2 / 2
  33.  
  34. ************************************************************************
  35. *     CREATION DE LA TABLE RESULTAT
  36. ************************************************************************
  37.       M = 3
  38.       SEGINI,MTABLE
  39.       MLOTAB = M
  40. *
  41. *     Sous-typage de la table resultat:
  42. *
  43.       CALL POSCHA('SOUSTYPE',IRET)
  44.       MTABTI(1) = 'MOT     '
  45.       MTABII(1) = IRET
  46.       MTABTV(1) = 'MOT     '
  47.       CALL POSCHA('RESULTAT_DYNC',IRET)
  48.       MTABIV(1) = IRET
  49. *
  50. *   + Sous-table REPONSE
  51. *
  52.       CALL POSCHA('REPONSE',IRET)
  53.       MTABTI(2) = 'MOT     '
  54.       MTABII(2) = IRET
  55.       MTABTV(2) = 'TABLE   '
  56.       IF (NOTYPS.EQ.1) THEN
  57.         M=7
  58.       ELSE
  59.         M=6
  60.       ENDIF
  61.       SEGINI,MTAB1
  62.       MTAB1.MLOTAB = M
  63.       MTABIV(2) = MTAB1
  64. *
  65. *   +-+ Remplissage de la Sous-table REPONSE
  66.         CALL POSCHA('NORME_DEPLACEMENT',IRET)
  67.         MTAB1.MTABTI(1) = 'MOT     '
  68.         MTAB1.MTABII(1) = IRET
  69.         MTAB1.MTABTV(1) = 'LISTREEL'
  70.         JG=NPAS
  71.         SEGINI, MLREEL
  72.         MTAB1.MTABIV(1) = MLREEL
  73. *
  74.         CALL POSCHA('FREQUENCE',IRET)
  75.         MTAB1.MTABTI(2) = 'MOT     '
  76.         MTAB1.MTABII(2) = IRET
  77.         MTAB1.MTABTV(2) = 'LISTREEL'
  78.         JG=NPAS
  79.         SEGINI, MLREE2
  80.         MTAB1.MTABIV(2) = MLREE2
  81. *
  82.         CALL POSCHA('STABILITE',IRET)
  83.         MTAB1.MTABTI(3) = 'MOT     '
  84.         MTAB1.MTABII(3) = IRET
  85.         MTAB1.MTABTV(3) = 'LISTENTI'
  86.         JG=NPAS
  87.         SEGINI, MLENT3
  88.         MTAB1.MTABIV(3) = MLENT3
  89.  
  90. *       remplissage de MLREEL = NORME_DEPLACEMENT
  91. *                      MLREE2 = FREQUENCE
  92. *                   et MLENT3 = STABILITE
  93. *
  94. c       boucle sur les pas
  95.         DO I=1,NPAS
  96. c          NORME_DEPLACEMENT
  97.            PROG(I)         = dnrm2(NT1,QSAVE(1,I),1)
  98.            IF (IERR.NE.0) RETURN
  99. c          FREQUENCE
  100.            MLREE2.PROG(I)  = WSAVE(I)
  101. c          (in)STABILITE
  102.            IF (ZSAVE(I)) THEN
  103.              MLENT3.LECT(I) = 0
  104.            ELSE
  105.              MLENT3.LECT(I) = 1
  106.            ENDIF
  107.         END DO
  108.         SEGDES,MLREEL,MLREE2,MLENT3
  109. *
  110. c       Remplissage de la table COEFFICIENTS
  111. *
  112.         CALL POSCHA('COEFFICIENTS',IRET)
  113.         MTAB1.MTABTI(4) = 'MOT     '
  114.         MTAB1.MTABII(4) = IRET
  115.         MTAB1.MTABTV(4) = 'TABLE   '
  116. cbp        M=NT1
  117. cbp        SEGINI,MTAB4
  118. cbp        MTAB4.MLOTAB = M
  119. cbp        MTAB1.MTABIV(4) = MTAB4
  120. cbp        DO J = 1,NT1
  121. cbp          MTAB4.MTABTI(J) = 'ENTIER   '
  122. cbp          MTAB4.MTABII(J) = J
  123. cbp          MTAB4.MTABTV(J) = 'LISTREEL'
  124. cbp          JG = NPAS
  125. cbp          SEGINI,MLREE2
  126. cbp          MTAB4.MTABIV(J) = MLREE2
  127. cbp          DO I = 1,NPAS
  128. cbp            MLREE2.PROG(I) = QSAVE(J,I)
  129. cbp          ENDDO
  130. cbp        ENDDO
  131. cbp        SEGDES,MTAB4,MLREE2
  132.  
  133. *       rem :  Q1 et QSAVE sont ranges dans l'ordre :
  134. *              ( Q1^{j=0}    Q1^{j=+1}     Q1^{j=-1}  ... Q1^{j=-nhbm} )
  135. *                constant     cos(wt)       sin(wt)   ...  sin(nwt)
  136. *           J1 =   1           2             3        ...  2*nhbm+1
  137.  
  138. *       sous-table des harmoniques
  139.         M=2*NHBM+1
  140.         SEGINI,MTAB4
  141.         MTAB4.MLOTAB = M
  142.         MTAB1.MTABIV(4) = MTAB4
  143.         JQ1=0
  144.         J  =0
  145.         ZPLUS=.true.
  146. *       boucle sur les harmoniques
  147.         DO J1=1,2*NHBM+1
  148. *         sous-sous-table des modes
  149.           M=NA1
  150.           SEGINI,MTAB5
  151.           MTAB5.MLOTAB = M
  152.           MTAB4.MTABTI(J1) = 'ENTIER   '
  153.           MTAB4.MTABII(J1) = J
  154.           MTAB4.MTABTV(J1) = 'TABLE    '
  155.           MTAB4.MTABIV(J1) = MTAB5
  156. *         boucle sur les modes
  157.           DO IA1=1,NA1
  158.             JG = NPAS
  159.             SEGINI,MLREEL
  160. c             MTAB5.MTABTI(IA1) = 'ENTIER   '
  161. c             MTAB5.MTABII(IA1) = IA1
  162. cbp : par coherence avec DYNE, l'indice est le point_repere du mode
  163.             MTAB5.MTABTI(IA1) = 'POINT   '
  164.             MTAB5.MTABII(IA1) = IPOREF(IA1)
  165.             MTAB5.MTABTV(IA1) = 'LISTREEL'
  166.             MTAB5.MTABIV(IA1)   = MLREEL
  167.             JQ1=JQ1+1
  168.             DO I = 1,NPAS
  169.                MLREEL.PROG(I) = QSAVE(JQ1,I)
  170.             ENDDO
  171.             SEGDES,MLREEL
  172.           ENDDO
  173. *         prochaine valeur de J
  174.           IF(ZPLUS) THEN
  175.             J=J+J1
  176.           ELSE
  177.             J=J-J1
  178.           ENDIF
  179.           ZPLUS=.not.ZPLUS
  180.           SEGDES,MTAB5
  181.         ENDDO
  182.         SEGDES,MTAB4
  183. *
  184.         CALL POSCHA('EXPOSANT_REEL',IRET)
  185.         MTAB1.MTABTI(5) = 'MOT     '
  186.         MTAB1.MTABII(5) = IRET
  187.         MTAB1.MTABTV(5) = 'TABLE   '
  188.         M=NA1x2
  189.         SEGINI,MTAB5
  190.         MTAB5.MLOTAB=M
  191.         MTAB1.MTABIV(5) = MTAB5
  192. *
  193.         CALL POSCHA('EXPOSANT_IMAGINAIRE',IRET)
  194.         MTAB1.MTABTI(6) = 'MOT     '
  195.         MTAB1.MTABII(6) = IRET
  196.         MTAB1.MTABTV(6) = 'TABLE   '
  197.         M=NA1x2
  198.         SEGINI,MTAB6
  199.         MTAB6.MLOTAB=M
  200.         MTAB1.MTABIV(6) = MTAB6
  201. *
  202. c       remplissage des tables EXPOSANT_REEL et EXPOSANT_IMAGINAIRE
  203.         DO J=1,NA1x2
  204.           MTAB5.MTABTI(J) = 'ENTIER   '
  205.           MTAB5.MTABII(J) = J
  206.           MTAB5.MTABTV(J) = 'LISTREEL'
  207.           MTAB6.MTABTI(J) = 'ENTIER   '
  208.           MTAB6.MTABII(J) = J
  209.           MTAB6.MTABTV(J) = 'LISTREEL'
  210.           JG=NPAS
  211.           SEGINI,MLREE1,MLREE2
  212.           MTAB5.MTABIV(J) = MLREE1
  213.           MTAB6.MTABIV(J) = MLREE2
  214. *         remplissage des listreels µR et µI
  215.           DO I=1,NPAS
  216.             MLREE1.PROG(I)=LSAVE(1,J,I)
  217.             MLREE2.PROG(I)=LSAVE(2,J,I)
  218.           ENDDO
  219.         ENDDO
  220.         SEGDES,MTAB5,MTAB6,MLREE1,MLREE2
  221.  
  222. *
  223. c     cas autonome: on sauvegarde la valeur du parametre de continuation
  224.         IF (NOTYPS.EQ.1) THEN
  225.           CALL POSCHA('PARAMC',IRET)
  226.           MTAB1.MTABTI(7) = 'MOT     '
  227.           MTAB1.MTABII(7) = IRET
  228.           MTAB1.MTABTV(7) = 'LISTREEL'
  229.           JG=NPAS
  230.           SEGINI, MLREE3
  231.           MTAB1.MTABIV(7) = MLREE3
  232.           DO I = 1,NPAS
  233.             MLREE3.PROG(I) = VSAVE(I)
  234.           ENDDO
  235.           SEGDES,MLREE3
  236.         ENDIF
  237. *
  238. *   + Sous-table BIFURCATION
  239. *
  240.       MTABTI(3) = 'MOT     '
  241.       CALL POSCHA('BIFURCATION',IRET)
  242.       MTABII(3) = IRET
  243.       MTABTV(3) = 'TABLE   '
  244.       M=7
  245.       SEGINI,MTAB2
  246.       MTAB2.MLOTAB = M
  247.       MTABIV(3) = MTAB2
  248. *
  249. *   +-+ Remplissage de la Sous-table BIFURCATION
  250.       CALL POSCHA('TYPE',IRET)
  251.       MTAB2.MTABTI(1) = 'MOT     '
  252.       MTAB2.MTABII(1) = IRET
  253.       MTAB2.MTABTV(1) = 'LISTMOTS'
  254.       JGN = 2
  255.       JGM=CBIF
  256.       SEGINI, MLMOTS
  257.       MTAB2.MTABIV(1) = MLMOTS
  258. *
  259.       CALL POSCHA('NORME_DEPLACEMENT',IRET)
  260.       MTAB2.MTABTI(2) = 'MOT     '
  261.       MTAB2.MTABII(2) = IRET
  262.       MTAB2.MTABTV(2) = 'LISTREEL'
  263.       JG=CBIF
  264.       SEGINI, MLREEL
  265.       MTAB2.MTABIV(2) = MLREEL
  266. *
  267.       CALL POSCHA('FREQUENCE',IRET)
  268.       MTAB2.MTABTI(3) = 'MOT     '
  269.       MTAB2.MTABII(3) = IRET
  270.       MTAB2.MTABTV(3) = 'LISTREEL'
  271.       JG=CBIF
  272.       SEGINI, MLREE2
  273.       MTAB2.MTABIV(3) = MLREE2
  274. *
  275.       CALL POSCHA('KAPPA',IRET)
  276.       MTAB2.MTABTI(4) = 'MOT     '
  277.       MTAB2.MTABII(4) = IRET
  278.       MTAB2.MTABTV(4) = 'LISTREEL'
  279.       JG=CBIF
  280.       SEGINI, MLREE3
  281.       MTAB2.MTABIV(4) = MLREE3
  282. *
  283. *     Remplissage de MLMOTS, MLREEL, MLREE2 et MLENT3
  284. c     Boucle sur les bifurcations
  285.       DO I=1,CBIF
  286. c     TYPE
  287.         IF (TYPBIF(I).EQ.'L') THEN
  288.           MOTS(I) = 'LP'
  289.         ENDIF
  290.         IF (TYPBIF(I).EQ.'B') THEN
  291.           MOTS(I) = 'BP'
  292.         ENDIF
  293.         IF (TYPBIF(I).EQ.'P') THEN
  294.           MOTS(I) = 'PD'
  295.         ENDIF
  296.         IF (TYPBIF(I).EQ.'N') THEN
  297.           MOTS(I) = 'NS'
  298.         ENDIF
  299. c     NORME_DEPLACEMENT
  300.         PROG(I)         = dnrm2(NT1,QBIFU(1,I),1)
  301.         IF (IERR.NE.0) RETURN
  302. c     FREQUENCE
  303.         MLREE2.PROG(I)  = WBIFU(I)
  304. c     KAPPA
  305.         MLREE3.PROG(I)  = WBIF2(I)
  306.       ENDDO
  307.       SEGDES,MLREEL,MLREE2,MLREE3,MLMOTS
  308. *
  309.         CALL POSCHA('VECTEUR_REEL',IRET)
  310.         MTAB2.MTABTI(5) = 'MOT     '
  311.         MTAB2.MTABII(5) = IRET
  312.         MTAB2.MTABTV(5) = 'TABLE   '
  313.         M=CBIF
  314.         SEGINI,MTAB4
  315.         MTAB4.MLOTAB=M
  316.         MTAB2.MTABIV(5) = MTAB4
  317. *
  318.         CALL POSCHA('VECTEUR_IMAGINAIRE',IRET)
  319.         MTAB2.MTABTI(6) = 'MOT     '
  320.         MTAB2.MTABII(6) = IRET
  321.         MTAB2.MTABTV(6) = 'TABLE   '
  322.         M=CBIF
  323.         SEGINI,MTAB5
  324.         MTAB5.MLOTAB=M
  325.         MTAB2.MTABIV(6) = MTAB5
  326. *
  327.         CALL POSCHA('COEFFICIENTS',IRET)
  328.         MTAB2.MTABTI(7) = 'MOT     '
  329.         MTAB2.MTABII(7) = IRET
  330.         MTAB2.MTABTV(7) = 'TABLE   '
  331.         M=CBIF
  332.         SEGINI,MTAB6
  333.         MTAB6.MLOTAB=M
  334.         MTAB2.MTABIV(7) = MTAB6
  335. *
  336. c       Remplissage des tables VECTEUR_REEL, VECTEUR_IMAGINAIRE et
  337. c       COEFFICIENTS
  338.         DO J=1,CBIF
  339.           MTAB4.MTABTI(J) = 'ENTIER   '
  340.           MTAB4.MTABII(J) = J
  341.           MTAB4.MTABTV(J) = 'LISTREEL'
  342.           MTAB5.MTABTI(J) = 'ENTIER   '
  343.           MTAB5.MTABII(J) = J
  344.           MTAB5.MTABTV(J) = 'LISTREEL'
  345.           MTAB6.MTABTI(J) = 'ENTIER   '
  346.           MTAB6.MTABII(J) = J
  347.           MTAB6.MTABTV(J) = 'LISTREEL'
  348.           JG=NPAS
  349.           SEGINI,MLREE1,MLREE2,MLREE3
  350.           MTAB4.MTABIV(J) = MLREE1
  351.           MTAB5.MTABIV(J) = MLREE2
  352.           MTAB6.MTABIV(J) = MLREE3
  353. *         Remplissage des listreels
  354.           DO I=1,NT1
  355.             MLREE1.PROG(I)= QPSIR(I,J)
  356.             MLREE2.PROG(I)= QPSII(I,J)
  357.             MLREE3.PROG(I)= QBIFU(I,J)
  358.           ENDDO
  359.         ENDDO
  360.  
  361. ************************************************************************
  362. *     FIN NORMALE : ON ECRIT LA TABLE RESULTAT
  363. ************************************************************************
  364.       CALL ECROBJ('TABLE',MTABLE)
  365.  
  366.       RETURN
  367.       END
  368.  
  369.  
  370.  

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