Télécharger la plaquette Cast3M


fr en

Télécharger mma.eso

Retour à la liste

Numérotation des lignes : 

mma

  1. C MMA       SOURCE    FD218221  25/09/03    21:15:03     12351          
  2.       SUBROUTINE MMA
  3.  
  4. C     Typages implicites habituels
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. C     Les includes necessaires
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCREEL
  12. -INC SMLREEL
  13. -INC SMTABLE
  14.  
  15. C     Segment pour stocker les donnees de la MMA
  16. C     Parametres :   NN = nombre d'inconnues
  17. C                    MM = nombre de contraintes
  18.       SEGMENT SMMA
  19.           INTEGER ITER
  20.           REAL*8  XVAL(NN,1),XMIN(NN,1),XMAX(NN,1)
  21.           REAL*8  A0,F0VAL,FVAL(MM,1),XOLD1(NN,1),XOLD2(NN,1)
  22.           REAL*8  DF0DX(NN,1),DFDX(MM,NN),LOW(NN,1),UPP(NN,1)
  23.           REAL*8  A(MM,1),C(MM,1),D(MM,1)
  24.  
  25.           REAL*8  XMMA(NN,1),YMMA(MM,1),ZMMA
  26.           REAL*8  LAM(MM,1),XSI(NN,1),ETA(NN,1),MU(MM,1),ZET,S(MM,1)
  27.       ENDSEGMENT
  28.       POINTEUR MMA1.SMMA,MMA2.SMMA
  29.  
  30. C     Quelques objets
  31.       LOGICAL BIND,BVALE
  32.       CHARACTER*1 MOTVAL
  33.       CHARACTER*8 TYPOBJ
  34.       REAL*8 MOVE
  35.  
  36. C     Acquisition des donnees d'entree utilisateur
  37. C     --> La table principale
  38.       CALL LIROBJ('TABLE',ITAB,1,IRETOU)
  39.       IF(IERR.NE.0) RETURN
  40. C     --> Vecteur des inconnues : XVAL
  41.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'X',BIND,IOIND,
  42.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  43.       IF (IERR.NE.0) GOTO 999
  44.       SEGACT MLREE1
  45. C     --> Nombre d'inconnues : N
  46.       N=MLREE1.PROG(/1)
  47.       IF (N.LT.1) THEN
  48.           CALL ERREUR(641)
  49.           RETURN
  50.       ENDIF
  51. C     --> Valeurs des fonctions contraintes en XVAL : FVAL
  52.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'FVAL',BIND,IOIND,
  53.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE2)
  54.       IF (IERR.NE.0) GOTO 999
  55.       SEGACT MLREE2
  56. C     --> Nombre de fonctions contraites : M
  57.       M=MLREE2.PROG(/1)
  58.       IF (M.LT.1) THEN
  59.           CALL ERREUR(641)
  60.           RETURN
  61.       ENDIF
  62. C     Initialisation du segment pour la MMA
  63.       NN=N
  64.       MM=M
  65.       SEGINI SMMA
  66. C     Remplissage des attributs XVAL et FVAL
  67.       DO I=1,N
  68.           XVAL(I,1)=MLREE1.PROG(I)
  69.       ENDDO
  70.       DO J=1,M
  71.           FVAL(J,1)=MLREE2.PROG(J)
  72.       ENDDO
  73.       IXVAL=MLREE1
  74.       SEGDES MLREE1,MLREE2
  75. C     --> Numero d'iteration : ITER (facultatif)
  76.       TYPOBJ='        '
  77.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'ITER',BIND,IOIND,
  78.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  79.       IF (IERR.NE.0) GOTO 999
  80.       IF (TYPOBJ.EQ.'ENTIER  ') THEN
  81.           ITER=IVALE
  82. C     Si indice 'ITER' non present, on prend 1
  83.       ELSE
  84.           ITER=1
  85.       ENDIF
  86. C     --> Vecteur des valeurs min pou les inconnues : XMIN (LISTREEL ou FLOTTANT)
  87.       TYPOBJ='        '
  88.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'XMIN',BIND,IOIND,
  89.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  90.       IF (IERR.NE.0) GOTO 999
  91. C     Si on a lu un LISTREEL, on le prend
  92.       IF (TYPOBJ.EQ.'LISTREEL') THEN
  93.           MLREE1=IOVALE
  94.           SEGACT MLREE1
  95.           IF (MLREE1.PROG(/1).NE.N) THEN
  96.               print*,'Mauvaise dimension pour XMIN'
  97.               GOTO 999
  98.           ENDIF
  99.           DO I=1,N
  100.               XMIN(I,1)=MLREE1.PROG(I)
  101.           ENDDO
  102.           SEGDES MLREE1
  103. C     Si on a lu un FLOTTANT, on l'utilise pour toutes les inconnues
  104.       ELSEIF (TYPOBJ.EQ.'FLOTTANT') THEN
  105.           DO I=1,N
  106.               XMIN(I,1)=XVALE
  107.           ENDDO
  108. C     Dans les autres cas, erreur
  109.       ELSE
  110.           MOTERR(1:11)='XMIN'
  111.           MOTERR(12:20)='LISTREEL'
  112.           CALL ERREUR(627)
  113.           RETURN
  114.       ENDIF
  115. C     --> Vecteur des valeurs min pou les inconnues : XMAX (LISTREEL ou FLOTTANT)
  116.       TYPOBJ='        '
  117.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'XMAX',BIND,IOIND,
  118.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  119.       IF (IERR.NE.0) GOTO 999
  120. C     Si on a lu un LISTREEL, on le prend
  121.       IF (TYPOBJ.EQ.'LISTREEL') THEN
  122.           MLREE1=IOVALE
  123.           SEGACT MLREE1
  124.           IF (MLREE1.PROG(/1).NE.N) THEN
  125.               print*,'Mauvaise dimension pour XMAX'
  126.               GOTO 999
  127.           ENDIF
  128.           DO I=1,N
  129.               XMAX(I,1)=MLREE1.PROG(I)
  130.           ENDDO
  131.           SEGDES MLREE1
  132. C     Si on a lu un FLOTTANT, on l'utilise pour toutes les inconnues
  133.       ELSEIF (TYPOBJ.EQ.'FLOTTANT') THEN
  134.           DO I=1,N
  135.               XMAX(I,1)=XVALE
  136.           ENDDO
  137. C     Dans les autres cas, erreur
  138.       ELSE
  139.           MOTERR(1:11)='XMAX'
  140.           MOTERR(12:20)='LISTREEL'
  141.           CALL ERREUR(627)
  142.           RETURN
  143.       ENDIF
  144. C     --> Vecteur des inconnues precedentes : XOLD1 (facultatif)
  145.       TYPOBJ='        '
  146.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'XOLD1',BIND,IOIND,
  147.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  148.       IF (IERR.NE.0) GOTO 999
  149. C     Si indice 'XOLD1' non present, on prend XVAL
  150.       IF (TYPOBJ.NE.'LISTREEL') THEN
  151.           MLREE1=IXVAL
  152.       ENDIF
  153.       SEGACT MLREE1
  154.       IF (MLREE1.PROG(/1).NE.N) THEN
  155.           print*,'Mauvaise dimension pour XOLD1'
  156.           GOTO 999
  157.       ENDIF
  158.       DO I=1,N
  159.           XOLD1(I,1)=MLREE1.PROG(I)
  160.       ENDDO
  161.       IXOLD1=MLREE1
  162.       SEGDES MLREE1
  163. C     --> Vecteur des inconnues precedentes : XOLD2 (facultatif)
  164.       TYPOBJ='        '
  165.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'XOLD2',BIND,IOIND,
  166.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  167.       IF (IERR.NE.0) GOTO 999
  168. C     Si indice 'XOLD2' non present, on prend XOLD1
  169.       IF (TYPOBJ.NE.'LISTREEL') THEN
  170.           MLREE1=IXOLD1
  171.       ENDIF
  172.       SEGACT MLREE1
  173.       IF (MLREE1.PROG(/1).NE.N) THEN
  174.           print*,'Mauvaise dimension pour XOLD2'
  175.           GOTO 999
  176.       ENDIF
  177.       DO I=1,N
  178.           XOLD2(I,1)=MLREE1.PROG(I)
  179.       ENDDO
  180.       SEGDES MLREE1
  181. C     --> Vecteur de l'asymptote inferieure : LOW (facultatif)
  182.       TYPOBJ='        '
  183.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'LOW',BIND,IOIND,
  184.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  185.       IF (IERR.NE.0) GOTO 999
  186.       IF (TYPOBJ.EQ.'LISTREEL') THEN
  187.           SEGACT MLREE1
  188.           IF (MLREE1.PROG(/1).NE.N) THEN
  189.               print*,'Mauvaise dimension pour LOW'
  190.               GOTO 999
  191.           ENDIF
  192.           DO I=1,N
  193.               LOW(I,1)=MLREE1.PROG(I)
  194.           ENDDO
  195.           SEGDES MLREE1
  196. C     Si indice 'LOW' non present, on prend XMIN
  197.       ELSE
  198.           LOW=XMIN
  199.       ENDIF
  200. C     --> Vecteur de l'asymptote superieure : UPP (facultatif)
  201.       TYPOBJ='        '
  202.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'UPP',BIND,IOIND,
  203.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  204.       IF (IERR.NE.0) GOTO 999
  205.       IF (TYPOBJ.EQ.'LISTREEL') THEN
  206.           SEGACT MLREE1
  207.           IF (MLREE1.PROG(/1).NE.N) THEN
  208.               print*,'Mauvaise dimension pour UPP'
  209.               GOTO 999
  210.           ENDIF
  211.           DO I=1,N
  212.               UPP(I,1)=MLREE1.PROG(I)
  213.           ENDDO
  214.           SEGDES MLREE1
  215. C     Si indice 'UPP' non present, on prend XMAX
  216.       ELSE
  217.           UPP=XMAX
  218.       ENDIF
  219. C     --> Valeur de la fonction objectif en XVAL : F0VAL
  220.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'F0VAL',BIND,IOIND,
  221.      &            'FLOTTANT',IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  222.       IF (IERR.NE.0) GOTO 999
  223.       F0VAL=XVALE
  224. C     --> Vecteur des derivees partielles dF0/dxi : DF0DX
  225.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'DF0DX',BIND,IOIND,
  226.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  227.       IF (IERR.NE.0) GOTO 999
  228.       SEGACT MLREE1
  229.       IF (MLREE1.PROG(/1).NE.N) THEN
  230.           print*,'Mauvaise dimension pour DF0DX'
  231.           GOTO 999
  232.       ENDIF
  233.       DO I=1,N
  234.           DF0DX(I,1)=MLREE1.PROG(I)
  235.       ENDDO
  236.       SEGDES MLREE1
  237. C     --> Matrice des derivees partielles dFj/dxi : DFDX
  238.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'DFDX',BIND,IOIND,
  239.      &            'TABLE   ',IVALE,XVALE,MOTVAL,BVALE,MTAB1)
  240.       IF (IERR.NE.0) GOTO 999
  241.       SEGACT MTAB1
  242.       DO J=1,M
  243.           CALL ACCTAB(MTAB1,'ENTIER  ',J,XIND,' ',BIND,IOIND,
  244.      &                'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  245.           IF (IERR.NE.0) GOTO 999
  246.           SEGACT MLREE1
  247.           IF (MLREE1.PROG(/1).NE.N) THEN
  248.               print*,'Mauvaise dimension pour la liste DFDX . ',J
  249.               GOTO 999
  250.           ENDIF
  251.           DO I=1,N
  252.               DFDX(J,I)=MLREE1.PROG(I)
  253.           ENDDO
  254.           SEGDES MLREE1
  255.       ENDDO
  256.       SEGDES MTAB1
  257. C     --> Valeur du coefficient A0 : A0
  258.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'A0',BIND,IOIND,
  259.      &            'FLOTTANT',IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  260.       IF (IERR.NE.0) GOTO 999
  261.       A0=XVALE
  262. C     --> Vecteur des coefficients A : A
  263.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'A',BIND,IOIND,
  264.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  265.       IF (IERR.NE.0) GOTO 999
  266.       SEGACT MLREE1
  267.       IF (MLREE1.PROG(/1).NE.M) THEN
  268.           print*,'Mauvaise dimension pour A'
  269.           GOTO 999
  270.       ENDIF
  271.       DO I=1,M
  272.           A(I,1)=MLREE1.PROG(I)
  273.       ENDDO
  274.       SEGDES MLREE1
  275. C     --> Vecteur des coefficients C : C
  276.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'C',BIND,IOIND,
  277.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  278.       IF (IERR.NE.0) GOTO 999
  279.       SEGACT MLREE1
  280.       IF (MLREE1.PROG(/1).NE.M) THEN
  281.           print*,'Mauvaise dimension pour C'
  282.           GOTO 999
  283.       ENDIF
  284.       DO I=1,M
  285.           C(I,1)=MLREE1.PROG(I)
  286.       ENDDO
  287.       SEGDES MLREE1
  288. C     --> Vecteur des coefficients D : D
  289.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'D',BIND,IOIND,
  290.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  291.       IF (IERR.NE.0) GOTO 999
  292.       SEGACT MLREE1
  293.       IF (MLREE1.PROG(/1).NE.M) THEN
  294.           print*,'Mauvaise dimension pour D'
  295.           GOTO 999
  296.       ENDIF
  297.       DO I=1,M
  298.           D(I,1)=MLREE1.PROG(I)
  299.       ENDDO
  300.       SEGDES MLREE1
  301. C     --> Parametre de mise a jour des asymptotes : MOVE (facultatif)
  302.       TYPOBJ='        '
  303.       CALL ACCTAB(ITAB,'MOT     ',IIND,XIND,'MOVE',BIND,IOIND,
  304.      &            TYPOBJ,IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  305.       IF (IERR.NE.0) GOTO 999
  306.       IF (TYPOBJ.EQ.'FLOTTANT') THEN
  307.           MOVE=XVALE
  308. C     Si indice 'MOVE' non present, on prend 0.1 et on l'ecrit dans la table
  309.       ELSE
  310.           MOVE=0.1D0
  311.           CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'MOVE',BIND,IOIND,
  312.      &                'FLOTTANT',IVALE,MOVE,MOTVAL,BVALE,IOVALE)
  313.       ENDIF
  314.  
  315. C     Appel a la subroutine qui fait le travail
  316. C     Pour la MMA classique ...
  317.       CALL MMASUB(M,N,ITER,XVAL,XMIN,XMAX,XOLD1,XOLD2,
  318.      &            F0VAL,DF0DX,FVAL,DFDX,A0,A,C,D,MOVE,
  319.      &            XMMA,YMMA,ZMMA,LAM,XSI,ETA,MU,ZET,S,LOW,UPP)
  320.  
  321.  
  322. C     Fin normale du programme
  323.       IF (IERR.NE.0) RETURN
  324. C     On ecrit les resultats dans la table d'entree sous forme de LISTREEL
  325. C     Ecrasement du numero d'iteration ITER <-- ITER+1
  326.       ITERP1=ITER+1
  327.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'ITER',BIND,IOIND,
  328.      &            'ENTIER  ',ITERP1,XVALE,MOTVAL,BVALE,IOVALE)
  329. C     Ecrasement des inconnues XVAL <-- XMMA
  330.       JG=N
  331.       SEGINI MLREE1
  332.       DO I=1,N
  333.           MLREE1.PROG(I)=XMMA(I,1)
  334.       ENDDO
  335.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'X',BIND,IOIND,
  336.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  337.       SEGDES MLREE1
  338. C     Ecrasement des inconnues precedentes XOLD1 <-- XVAL
  339.       MLREE1=IXVAL
  340.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'XOLD1',BIND,IOIND,
  341.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  342.       SEGDES MLREE1
  343. C     Ecrasement des inconnues pre-precedentes XOLD2 <-- XOLD1
  344.       MLREE1=IXOLD1
  345.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'XOLD2',BIND,IOIND,
  346.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  347.       SEGDES MLREE1
  348. C     Ecrasement des asymptotes inferieures LOW <-- LOW
  349.       JG=N
  350.       SEGINI MLREE1
  351.       DO I=1,N
  352.           MLREE1.PROG(I)=LOW(I,1)
  353.       ENDDO
  354.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'LOW',BIND,IOIND,
  355.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  356.       SEGDES MLREE1
  357. C     Ecrasement des asymptotes superieures UPP <-- UPP
  358.       JG=N
  359.       SEGINI MLREE1
  360.       DO I=1,N
  361.           MLREE1.PROG(I)=UPP(I,1)
  362.       ENDDO
  363.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'UPP',BIND,IOIND,
  364.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  365.       SEGDES MLREE1
  366. C     On rend aussi les autres variables
  367. C     Vecteur YMMA (variables y)
  368.       JG=M
  369.       SEGINI MLREE1
  370.       DO I=1,M
  371.           MLREE1.PROG(I)=YMMA(I,1)
  372.       ENDDO
  373.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'Y',BIND,IOIND,
  374.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  375.       SEGDES MLREE1
  376. C     Scalaire ZMMA (variable z)
  377.       XVALE=ZMMA
  378.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'Z',BIND,IOIND,
  379.      &            'FLOTTANT',IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  380. C     Vecteur LAM (multiplicateurs de Lagrange pour les contraintes f_i)
  381.       JG=M
  382.       SEGINI MLREE1
  383.       DO I=1,M
  384.           MLREE1.PROG(I)=LAM(I,1)
  385.       ENDDO
  386.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'LAMBDA',BIND,IOIND,
  387.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  388.       SEGDES MLREE1
  389. C     Vecteur XSI (multiplicateurs de Lagrange pour les bornes inferieures)
  390.       JG=N
  391.       SEGINI MLREE1
  392.       DO I=1,N
  393.           MLREE1.PROG(I)=XSI(I,1)
  394.       ENDDO
  395.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'XSI',BIND,IOIND,
  396.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  397.       SEGDES MLREE1
  398. C     Vecteur ETA (multiplicateurs de Lagrange pour les bornes superieures)
  399.       JG=N
  400.       SEGINI MLREE1
  401.       DO I=1,N
  402.           MLREE1.PROG(I)=ETA(I,1)
  403.       ENDDO
  404.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'ETA',BIND,IOIND,
  405.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  406.       SEGDES MLREE1
  407. C     Vecteur MU (multiplicateurs de Lagrange y_i > 0)
  408.       JG=M
  409.       SEGINI MLREE1
  410.       DO I=1,M
  411.           MLREE1.PROG(I)=MU(I,1)
  412.       ENDDO
  413.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'MU',BIND,IOIND,
  414.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  415.       SEGDES MLREE1
  416. C     Scalaire ZET (multiplicateur de Lagrange pour z > 0)
  417.       XVALE=ZET
  418.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'ZET',BIND,IOIND,
  419.      &            'FLOTTANT',IVALE,XVALE,MOTVAL,BVALE,IOVALE)
  420. C     Vecteur S (variables d'ecart pour les contraintes f_i)
  421.       JG=M
  422.       SEGINI MLREE1
  423.       DO I=1,M
  424.           MLREE1.PROG(I)=S(I,1)
  425.       ENDDO
  426.       CALL ECCTAB(ITAB,'MOT     ',IIND,XIND,'S',BIND,IOIND,
  427.      &            'LISTREEL',IVALE,XVALE,MOTVAL,BVALE,MLREE1)
  428.       SEGDES MLREE1
  429. C     Et c'est fini !
  430.       RETURN
  431.  
  432. C     En cas d'erreur
  433. 999   CONTINUE
  434.       CALL ERREUR(26)
  435.       RETURN
  436.  
  437.       END
  438.  
  439.  

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