1 : C MAXIN1 SOURCE CHAT 05/01/13 01:36:38 5004 2 : SUBROUTINE MAXIN1(IPCHPO,IPLMOT,MOTCLE,IPLACE,PGRAND,KPLUS,LABSO) 3 : ************************************************************************ 4 : * 5 : * M A X I N 1 6 : * ----------- 7 : * 8 : * FONCTION: 9 : * --------- 10 : * 11 : * RECHERCHER LA PLUS GRANDE VALEUR D'UN 'CHPOINT'. 12 : * 13 : * COMPLETEMENT INSPIRE DE MAXIM1 QUI RECHERCHE LE MAXIMUM EN 14 : * VALEUR ABSOLUE ( VOIR MAXIM1 POUR COMMENTAIRES ) 15 : * 16 : * 17 : ************************************************************************ 18 : * 19 : IMPLICIT INTEGER(I-N) 20 : -INC CCOPTIO 21 : -INC SMCHPOI 22 : -INC SMLMOTS 23 : * 24 : CHARACTER*4 MOTCLE 25 : REAL*8 PGRAND,XVAL 26 : * 27 : LOGICAL DEDANS,TRUFAL 28 : * 29 : SEGMENT/MTEMP2/ (MAXSOU,MAXN,MAXNC) 30 : * 31 : * 32 : * 33 : IF (IPLMOT .EQ. 0) THEN 34 : * 35 : DEDANS = .TRUE. 36 : TRUFAL = DEDANS 37 : * 38 : ELSE 39 : * 40 : IF (MOTCLE .EQ. 'AVEC') THEN 41 : TRUFAL = .TRUE. 42 : ELSE IF (MOTCLE .EQ. 'SANS') THEN 43 : TRUFAL = .FALSE. 44 : ELSE 45 : * MOT-CLE NON RECONNU: 46 : MOTERR(1:4)=MOTCLE 46 : CALL ERREUR (7) 47 : RETURN 48 : END IF 49 : * 50 : MLMOTS = IPLMOT 51 : SEGACT,MLMOTS 52 : NBRMOT = MOTS(/2) 53 : SEGDES,MLMOTS 54 : * 55 : END IF 56 : * 57 : * RQ: A CE NIVEAU, "MOTCLE" EST DIFFERENT DE "MOCLE1" ET DE "MOCLE2" 58 : * SI ET SEULEMENT SI IPLMOT = 0 . 59 : * 60 : * 61 : MCHPOI = IPCHPO 62 : SEGACT,MCHPOI 63 : NSOUPO = IPCHP(/1) 64 : PGRAND = 0.D0 65 : IDEB=0 66 : * 67 : MTEMP2 = MCHPOI 68 : IF (IPLACE .NE. 0) THEN 69 : MTEMP2 = IPLACE 70 : SEGACT,MTEMP2 71 : MAXSOU = 1 72 : MAXN = 1 73 : MAXNC = 1 74 : END IF 75 : * 76 : IF (IPLMOT .NE. 0) THEN 77 : MLMOTS = IPLMOT 78 : SEGACT,MLMOTS 79 : END IF 80 : * 81 : * -- RECHERCHE DU MAXIMUM -- 82 : * 83 : DO 100 IB100=1,NSOUPO 84 : * 85 : MSOUPO = IPCHP(IB100) 86 : SEGACT,MSOUPO 87 : NC = NOCOMP(/2) 88 : MPOVAL = IPOVAL 89 : SEGACT,MPOVAL 90 : N = VPOCHA(/1) 91 : * 92 : if (n.gt.0) then 93 : DO 120 IB120=1,NC 94 : * 95 : IF (IPLMOT .NE. 0) THEN 95 : CALL PARMI (NOCOMP(IB120),MOTS,NBRMOT, DEDANS) 96 : END IF 97 : * 98 : * SI LA COMPOSANTE NOCOMP(IB120) FAIT PARTIE DES COMPOSANTES 99 : * RETENUES POUR LA RECHERCHE DU MAXIMUM, ALORS... 100 : ** IF (DEDANS .EQV. TRUFAL) THEN 101 : ** (LIGNE CI-DESSUS INCOMPRISE PAR ESOPE 4.1.1 (MARS 84) ) 102 : IF((DEDANS.AND.TRUFAL).OR.((.NOT.DEDANS).AND.(.NOT.TRUFAL))) 103 : & THEN 104 : * 105 : IF(IDEB.EQ.0) THEN 106 : IDEB=1 107 : IF(LABSO.EQ.0) THEN 108 : PGRAND=VPOCHA(1,IB120) 109 : ELSE 110 : PGRAND=ABS(VPOCHA(1,IB120)) 111 : ENDIF 112 : ENDIF 113 : * 114 : DO 130 IB130=1,N 115 : * A CAUSE D'UNE AGACERIE DU COMPILATEUR CRAY CFT115 116 : MPOVA1=MPOVAL 117 : IF(LABSO.EQ.0) THEN 118 : XVAL = MPOVA1.VPOCHA(IB130,IB120) 119 : ELSE 120 : XVAL = ABS(MPOVA1.VPOCHA(IB130,IB120)) 121 : ENDIF 122 : IF((KPLUS.EQ. 1.AND.XVAL.GT.PGRAND). 123 : $ OR.(KPLUS.EQ.-1.AND.XVAL.LT.PGRAND)) 124 : $ THEN 125 : IF (IPLACE .NE. 0) THEN 126 : MAXSOU = IB100 127 : MAXN = IB130 128 : MAXNC = IB120 129 : END IF 130 : PGRAND = XVAL 131 : END IF 132 : 130 CONTINUE 133 : * END DO 134 : END IF 135 : * 136 : 120 CONTINUE 137 : * END DO 138 : endif 139 : * 140 : SEGDES,MPOVAL 141 : SEGDES,MSOUPO 142 : * 143 : 100 CONTINUE 144 : * END DO 145 : * 146 : SEGDES,MCHPOI 147 : IF (IPLMOT .NE. 0) THEN 148 : MLMOTS = IPLMOT 149 : SEGDES,MLMOTS 150 : END IF 151 : IF (IPLACE .NE. 0) THEN 152 : MTEMP2 = IPLACE 153 : SEGDES,MTEMP2 154 : END IF 155 : * 156 : * -- A-T-ON OBTENU UN MAXIMUM ? -- 157 : * 158 : * IF (IDEB.EQ.0) THEN 159 : * SOIT LE 'CHPOINT' EST VIDE, SOIT LE 'LISTMOTS' CONTIENT DES 160 : * NOMS DE TYPE TELS QUE, ETANT DONNE LA VALEUR DU MOT-CLE, 161 : * TOUTES LES COMPOSANTES DU 'CHPOINT' SONT EXCLUES. 162 : * NUMERR = 156 162 : * CALL ERREUR (NUMERR) 163 : * RETURN 164 : * END IF 165 : * 166 : END 167 : 168 : 169 :
© Cast3M 2003 - All rights reserved.
Disclaimer