Télécharger la plaquette Cast3M


fr en

Télécharger maximu.eso

Retour à la liste

Numérotation des lignes : 

maximu

  1. C MAXIMU    SOURCE    FD218221  25/03/14    21:15:06     12200          
  2.  
  3.       SUBROUTINE MAXIMU(KPLUS)
  4.  
  5. ************************************************************************
  6. *
  7. *                             M A X I M U
  8. *                             -----------
  9. *
  10. *            SOUS-PROGRAMME ASSOCIE AUX OPERATEURS :
  11. *                   MAXI  ( KPLUS = 1 )
  12. *                   MINI  ( KPLUS =-1 )
  13. *
  14. * FONCTION:
  15. * ---------
  16. *
  17. *     DETERMINER LA PLUS GRANDE VALEUR D'UN OBJET (QUAND CELA A UN
  18. *     SENS).
  19. *
  20. * PHRASE D'APPEL (EN GIBIANE):
  21. * ----------------------------
  22. *
  23. *                                    |('AVEC')|
  24. *     GRANDVAL = MAXI OBJET ('ABS') (|        | COMPOS ) ;
  25. *                                    | 'SANS' |
  26. *
  27. *     INDICE2 ABSC3 ORDO4 = MAXI  EVOL1  ('ABS') ;
  28. *
  29. *     OBJET3   =  MAXI  OBJET1  OBJET2 (OBJETi ..) ;
  30. *
  31. *     CHP1  = MAXI 'NOEU' MOD1 ;
  32. *
  33. *     LES PARENTHESES INDIQUANT DES ARGUMENTS FACULTATIFS.
  34. *
  35. * OPERANDES ET RESULTATS:
  36. * -----------------------
  37. *
  38. *     OBJ       TYPE_1      OBJET DONT ON CHERCHE LA PLUS GRANDE VALEUR.
  39. *     GRANDVAL  TYPE_2      PLUS GRANDE VALEUR EXTRAITE DE "OBJ".
  40. *                           CETTE "PLUS GRANDE VALEUR" EST LA PLUS
  41. *                           GRANDE EN VALEUR ABSOLUE, MAIS ELLE EST
  42. *                           RETOURNEE AVEC SON SIGNE.
  43. *     AVEC      'MOT     '  MOT-CLE INDIQUANT QUE L'ON REGARDE
  44. *                           UNIQUEMENT,DANS LA RECHERCHE DU MAXIMUM,
  45. *                           LES VALEURS ASSOCIEES AUX COMPOSANTES CITEES
  46. *                           DANS "COMPOS".
  47. *                           C'EST L'OPTION PAR DEFAUT.
  48. *     SANS      'MOT     '  MOT-CLE INDIQUANT QUE L'ON EXCLUT, DANS LA
  49. *                           RECHERCHE DU MAXIMUM, LES VALEURS ASSOCIEES
  50. *                           AUX COMPOSANTES CITEES DANS "COMPOS".
  51. *     COMPOS    'LISTMOTS'  LISTE DES NOMS DES COMPOSANTES COMPRISES
  52. *                           OU EXCLUES.
  53. *
  54. *     SI TYPE_1 = 'CHPOINT', ALORS
  55. *        . TYPE_2 = 'FLOTTANT',
  56. *        . LES COMPOSANTES SONT UX,UY,UZ,RX,RY,RZ,LX,...
  57. *     SI TYPE_1 = 'LISTENTI', ALORS
  58. *        . TYPE_2 = 'ENTIER',
  59. *        . ON PRENDS TOUJOURS TOUTES LES COMPOSANTES EN CONSIDERATION.
  60. *     SI TYPE_1 = 'LISTREEL', ALORS
  61. *        . TYPE_2 = 'FLOTTANT',
  62. *        . ON PRENDS TOUJOURS TOUTES LES COMPOSANTES EN CONSIDERATION.
  63. *
  64. * LEXIQUE: (ORDRE ALPHABETIQUE)
  65. * --------
  66. *
  67. *     KGRAND  ENTIER    PLUS GRANDE VALEUR EXTRAITE (CAS DE VALEURS
  68. *                       ENTIERES).
  69. *     IPLMOT  ENTIER    POINTEUR DE L'OBJET "COMPOS".
  70. *     IPOINT  ENTIER    POINTEUR DE L'OBJET "OBJ".
  71. *     IPOS    ENTIER    NUMERO D'ORDRE DU TYPE DE L'OBJET "OBJ" DANS LA
  72. *                       LISTE CONTENUE DANS "LISTYP".
  73. *     LISTYP  ENTIER    CONTIENT LES NOMS DES DIFFERENTS TYPES D'OBJET
  74. *                       DONT ON PEUT RECHERCHER LA PLUS GRANDE VALEUR.
  75. *     MOTCLE  ENTIER    CONTIENT LA CHAINE DE CARACTERES 'AVEC' OU
  76. *                       'SANS'.
  77. *     NBTYPE  ENTIER    NOMBRE DE NOMS DANS "LISTYP".
  78. *     PGRAND  REEL DP   PLUS GRANDE VALEUR EXTRAITE (CAS DE VALEURS
  79. *                       REELLES).
  80. *
  81. * MODE DE FONCTIONNEMENT:
  82. * -----------------------
  83. *
  84. *     APPEL D'UN SOUS-PROGRAMME DISTINCT SELON LE TYPE DE L'OBJET "OBJ".
  85. *
  86. * SOUS-PROGRAMMES APPELES:
  87. * ------------------------
  88. *
  89. *     LIRE, LIRTYP, ECRIRE,MAXIN1, MAXIN2, MAXIN3,MAXICH,
  90. *     MAXIN4,MAXIN6,MAXIN7
  91. *
  92. * AUTEUR, DATE DE CREATION:
  93. * -------------------------
  94. *
  95. *     PASCAL MANIGOT     5 NOVEMBRE 1984
  96. *
  97. *     "MAXIMUM D'UN LISTENTI" AJOUTE LE 19 FEVRIER 1985  (P. MANIGOT)
  98. *     "MAXIMUM D'UN LISTREEL" AJOUTE LE 16 AVRIL 1985  (P. MANIGOT)
  99. *
  100. * LANGAGE:
  101. * --------
  102. *
  103. *     FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS
  104. *
  105. ************************************************************************
  106. *
  107.       IMPLICIT INTEGER(I-N)
  108.       IMPLICIT REAL*8(A-H,O-Z)
  109. *
  110.  
  111. -INC PPARAM
  112. -INC CCOPTIO
  113. -INC SMCHPOI
  114. *
  115.       PARAMETER (NBTYPE = 5, NBMOT = 4)
  116.       CHARACTER*8 LISTYP(NBTYPE),MONTYP
  117.       CHARACTER*4 LISMO(NBMOT)
  118.       CHARACTER*4 MOTCLE
  119.       DATA LISTYP / 'CHPOINT ','LISTENTI','LISTREEL','MCHAML  ',
  120.      &              'EVOLUTIO' /
  121.       DATA LISMO/'AVEC','SANS','ABS ','NOEU'/
  122.  
  123.       LOGICAL ZABSO
  124.  
  125. ************************************************************************
  126. *    LECTURES, INITIALISATION ET AIGUILLAGE
  127. ************************************************************************
  128. *
  129. *     -- LECTURE DU MOT-CLE --
  130. *
  131.       LABSO=0
  132.       CALL LIRMOT (LISMO,NBMOT,IPLAC,0)
  133.       IF (IERR.NE.0) RETURN
  134.  
  135. C     SI MOT CLEF 'NOEU' (SYNTAXE 4 :  MAXI/MINI AU NOEUDS DU MCHAML)
  136.       IF (IPLAC.EQ.4) THEN
  137. C       Lecture obligatoire d'un MMODEL
  138.         CALL LIROBJ('MMODEL  ',IPOI1,1,IRETO1)
  139.         CALL ACTOBJ('MMODEL  ',IPOI1,1)
  140.         IF(IERR.NE.0) RETURN
  141. C       Lecture obligatoire d'un MCHAML
  142.         CALL LIROBJ('MCHAML  ',IPOI2,1,IRETO2)
  143.         CALL ACTOBJ('MCHAML  ',IPOI2,1)
  144.         IF(IERR.NE.0) RETURN
  145. C       Reduction du MCHAML sur le MMODEL (au cas ou)
  146.         CALL REDUAF(IPOI2,IPOI1,IPOI3,0,IRET,KERR)
  147.         IF (IRET.EQ.0) THEN
  148.           CALL ERREUR (KERR)
  149.           IF(IERR .NE. 0) RETURN
  150.         ELSE
  151.           IPOI2=IPOI3
  152.         ENDIF
  153. C       Changement de support vers les noeuds
  154.         CALL CHASUP(IPOI1,IPOI2,IPOI3,IRT2,1)
  155.         IF(IRT2.NE.0) THEN
  156.           CALL ERREUR(IRT2)
  157.           RETURN
  158.         ENDIF
  159. C       Convertion en CHPOINT avec option 'MAXI' ou 'MINI'
  160.         IMOY=2*KPLUS
  161.         CALL CHAMPO(IPOI3,IMOY,IPOI4,IRET)
  162. C       On regele la nature du champ a 'DIFFUS'
  163.         MCHPOI=IPOI4
  164.         SEGACT MCHPOI*MOD
  165.         JATTRI(1)=1
  166. C       Ecriture du CHPOINT resultat et sortie
  167.         CALL ACTOBJ('CHPOINT ',IPOI4,1)
  168.         CALL ECROBJ('CHPOINT ',IPOI4)
  169.         RETURN
  170.       ENDIF
  171.  
  172.  
  173. C     AUTRES SYNTAXES
  174. C     LECTURE DU MOT CLEF 'ABS'
  175.       IF (IPLAC.EQ.3) THEN
  176. C        SI OUI, LECTURE DU MOT CLEF 'AVEC' OU 'SANS'
  177.          LABSO=1
  178.          CALL LIRMOT (LISMO,2,IPLAC,0)
  179.          IF (IERR.NE.0) RETURN
  180.       ENDIF
  181.       ZABSO=LABSO.eq.1
  182. *
  183. *        PAR DEFAUT, LES COMPOSANTES NOMMEES SONT LES COMPOSANTES
  184. *        PRISES EN COMPTE (ET NON PAS LES COMPOSANTES EXCLUES)
  185.       IF (IPLAC.EQ. 0) THEN
  186.          MOTCLE = 'AVEC'
  187.          ICODE = 0
  188.       ELSE
  189.          MOTCLE = LISMO(IPLAC)
  190.          ICODE = 1
  191.       END IF
  192. *
  193. *     -- LECTURE DE LA LISTE DES NOMS DES COMPOSANTES --
  194. *        (OBLIGATOIRE SI MOT CLE 'AVEC' OU 'SANS' EST PRECISE)
  195.       IPLMOT = 0
  196.       CALL LIROBJ('LISTMOTS',IPLMOT,ICODE,IRETOU)
  197.       IF (IERR.NE.0) RETURN
  198. *
  199. *     -- LECTURE DE L'OBJET --
  200. *
  201.       CALL QUETYP(MONTYP,0,IRETOU)
  202.       IF (IRETOU.EQ.0) THEN
  203.         CALL ERREUR(533)
  204.         RETURN
  205.       ENDIF
  206. *    -cas entier et flottant
  207.       IF(MONTYP.EQ.'ENTIER') GOTO 1
  208.       IF(MONTYP.EQ.'FLOTTANT') GOTO 2      
  209. *    -autres objets
  210.       DO 5 IPOS=1,NBTYPE
  211.         IF (MONTYP.EQ.LISTYP(IPOS)) GOTO 6
  212.    5  CONTINUE
  213. c     ERREUR 39 : On ne veut pas d'objet de type ...
  214.       MOTERR(1:8)=MONTYP
  215.       CALL ERREUR(39)
  216.       RETURN
  217.  
  218.  
  219. ************************************************************************
  220. c     -- MAXIMUM de n FLOTTANTS OU ENTIERS --
  221. ************************************************************************
  222.  
  223. *     ENTIERS
  224.    1  CONTINUE      
  225.       CALL LIRENT(IMAX,1,IRETOU)      
  226.       IF (IERR.NE.0) RETURN
  227.       if (ZABSO) IMAX=ABS(IMAX)
  228.       IF(KPLUS.eq.1) THEN
  229.   11    CALL LIRENT(IVAL,0,IRETOU)
  230.         IF(IRETOU.NE.0) THEN
  231.           if (ZABSO) IVAL=ABS(IVAL)
  232.           IMAX=MAX(IMAX,IVAL)
  233.           GOTO 11
  234.         ENDIF
  235.       ELSEIF(KPLUS.eq.-1) THEN
  236.   12    CALL LIRENT(IVAL,0,IRETOU)
  237.         IF(IRETOU.NE.0) THEN
  238.           if (ZABSO) IVAL=ABS(IVAL)
  239.           IMAX=MIN(IMAX,IVAL)
  240.           GOTO 12
  241.         ENDIF
  242.       ELSE
  243.         CALL ERREUR(5)
  244.         RETURN
  245.       ENDIF
  246.       CALL ECRENT(IMAX)
  247.       RETURN
  248.  
  249. *     FLOTTANTS
  250.    2  CONTINUE      
  251.       CALL LIRREE(XMAX,1,IRETOU)
  252.       IF (IERR.NE.0) RETURN
  253.       if (ZABSO) XMAX=ABS(XMAX)
  254.       IF(KPLUS.eq.1) THEN
  255.   21    CALL LIRREE(XVAL,0,IRETOU)
  256.         IF(IRETOU.NE.0) THEN
  257.           if (ZABSO) XVAL=ABS(XVAL)
  258.           XMAX=MAX(XMAX,XVAL)
  259.           GOTO 21
  260.         ENDIF
  261.       ELSEIF(KPLUS.eq.-1) THEN
  262.   22    CALL LIRREE(XVAL,0,IRETOU)
  263.         IF(IRETOU.NE.0) THEN
  264.           if (ZABSO) XVAL=ABS(XVAL)
  265.           XMAX=MIN(XMAX,XVAL)
  266.           GOTO 22
  267.         ENDIF
  268.       ELSE
  269.         CALL ERREUR(5)
  270.         RETURN
  271.       ENDIF
  272.       CALL ECRREE(XMAX)
  273.       RETURN
  274.  
  275.  
  276.  
  277. ************************************************************************
  278. c     on a trouve un objet compatible dans LISTYP : on le lit
  279. ************************************************************************
  280.    6  CONTINUE
  281.       CALL LIROBJ(MONTYP,IPOINT,1,IRETOU)
  282.       IF(IERR .NE. 0) RETURN
  283.       CALL ACTOBJ(MONTYP,IPOINT,1)
  284.       IF(IERR .NE. 0) RETURN
  285.  
  286. ************************************************************************
  287. c     -- MAXIMUM de n OBJETS (de type LISTENTI, LISTREEL ou CHPOINT) --
  288. ************************************************************************
  289.  
  290. c       if( ipos.eq.2.or.ipos.eq.3) then
  291.       if( ipos.le.3 ) then
  292.         CALL LIROBJ(MONTYP,IPOINT2,0,IRETOU)
  293. c       si on lit un 2nd objet du meme type
  294.         if( iretou.ne.0) then
  295.         CALL ACTOBJ(MONTYP,IPOINT2,1)
  296.         IF(IERR .NE. 0) RETURN
  297. c         CHPOINT
  298.           if( ipos.eq.1 )
  299.      &       call maxin7(ipoint,ipoint2,ipoint3,montyp,kplus,LABSO)
  300. c         LISTENTI ou LISREEL
  301.           if( ipos.eq.2.or.ipos.eq.3 )
  302.      &       call maxin6(ipoint,ipoint2,ipoint3,montyp,kplus,LABSO)
  303.           if(ierr.eq.0)call ecrobj(montyp,ipoint3)
  304.           return
  305.         endif
  306.       endif
  307.       IF (IERR .NE. 0) RETURN
  308. *
  309.  
  310. ************************************************************************
  311. *     -- RECHERCHE DU MAXIMUM d'1 OBJET --
  312. ************************************************************************
  313. *
  314.       IF (IPOS .EQ. 1) THEN
  315. *
  316. *        RECHERCHE DU MAXIMUM D'UN "CHPOINT":
  317.          IPLACE = 0
  318.          CALL MAXIN1 (IPOINT,IPLMOT,MOTCLE,IPLACE,PGRAND,KPLUS,LABSO)
  319.          IF (IERR .NE. 0) RETURN
  320.          CALL ECRREE (PGRAND)
  321. *
  322.       ELSE IF (IPOS .EQ. 2) THEN
  323. *
  324. *        RECHERCHE DU MAXIMUM D'UN 'LISTENTI':
  325.          CALL MAXIN2 (IPOINT,  IPLACE,KGRAND,KPLUS,LABSO)
  326.          IF (IERR .NE. 0) RETURN
  327.          CALL ECRENT (KGRAND)
  328. *
  329.       ELSE IF (IPOS .EQ. 3) THEN
  330. *
  331. *        RECHERCHE DU MAXIMUM D'UN 'LISTREEL':
  332.          CALL MAXIN3 (IPOINT,  IPLACE,PGRAND,KPLUS,LABSO)
  333.          IF (IERR .NE. 0) RETURN
  334.          CALL ECRREE (PGRAND)
  335. *
  336.       ELSE IF (IPOS .EQ. 4) THEN
  337. *
  338. *        RECHERCHE DU MAXIMUM D'UN "MCHAML":
  339.          IPLACE = 0
  340.          CALL MAXICH (IPOINT,IPLMOT,MOTCLE,IPLACE,PGRAND,KPLUS,LABSO)
  341.          IF (IERR .NE. 0) RETURN
  342.          CALL ECRREE (PGRAND)
  343. *
  344.       ELSE IF (IPOS .EQ. 5) THEN
  345. *
  346. *        RECHERCHE DU MAXIMUM D'UNE "EVOLUTIO":
  347.          IPLACE = 0
  348.          CALL MAXIN4 (IPOINT,IPLACE,AGRAND,OGRAND,KPLUS,LABSO,KGRAND,
  349.      &JGRAND)
  350.          IF (IERR .NE. 0) RETURN
  351.          if(kgrand.eq.0.and.jgrand.eq.0) then
  352.            CALL ECRREE (OGRAND)
  353.            CALL ECRREE (AGRAND)
  354.            CALL ECRENT(IPLACE)
  355.          else
  356.            CALL ECROBJ('LISTREEL',JGRAND)
  357.            CALL ECROBJ('LISTREEL',KGRAND)
  358.            CALL ECROBJ('LISTENTI',IPLACE)
  359.          endif
  360.       END IF
  361. *
  362.       RETURN
  363.       END
  364.  
  365.  
  366.  
  367.  
  368.  
  369.  
  370.  
  371.  
  372.  

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