C BORNE4 SOURCE PV 22/01/18 21:15:01 11267 SUBROUTINE BORNE4 (IPCHPE,MLCOMP,MLIOPE,MLBMIN,MLBMAX, IPCHPS) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C* -INC PPARAM -INC CCOPTIO -INC SMCHPOI -INC SMLENTI -INC SMLMOTS -INC SMLREEL CHARACTER*(LOCOMP) mocomp IPCHPS = 0 IRETS = 0 MCHPO1 = IPCHPE C Si CHPOINT vide en entree segact,MCHPO1 NS1 = MCHPO1.IPCHP(/1) IF (NS1.EQ.0) THEN IPCHPS = IPCHPE RETURN ENDIF SEGINI,MCHPOI=MCHPO1 C- Quelques verifications MLMOTS = MLCOMP C* SEGACT,MLMOTS DO i = 1, MOTS(/2) mocomp = MOTS(i) DO j = 1, i-1 IF (mocomp.EQ.MOTS(j)) MOTS(j) = ' ' ENDDO ENDDO NCOMP = 0 DO i = 1, MOTS(/2) IF (MOTS(i).NE.' ') NCOMP = NCOMP+1 ENDDO IF (NCOMP.EQ.0) CALL ERREUR(5) MLENT1 = MLIOPE C* SEGACT,MLENT1 MLREE1 = MLBMIN C* SEGACT,MLREE1 MLREE2 = MLBMAX C* SEGACT,MLREE2 C- Realisation du bornage des champs par point NSOUPO = IPCHP(/1) DO i = 1, NSOUPO MSOUP1 = IPCHP(i) SEGACT,MSOUP1 MPOVA1 = MSOUP1.IPOVAL SEGACT,MPOVA1 N = MPOVA1.VPOCHA(/1) NCOMP = MPOVA1.VPOCHA(/2) SEGINI,MSOUPO=MSOUP1 SEGINI,MPOVAL=MPOVA1 NC = 0 DO icour = 1, NCOMP mocomp = MSOUP1.NOCOMP(icour) C* IF (mocomp.EQ.' ') GOTO 100 CALL PLACE(MOTS,MOTS(/2),ncour,mocomp) IF (ncour.NE.0) THEN NC = NC+1 NOCOMP(NC) = mocomp NOHARM(NC) = MSOUP1.NOHARM(icour) INDOPE = MLENT1.LECT(ncour) XBMIN = MLREE1.PROG(ncour) XBMAX = MLREE2.PROG(ncour) C- BORNER 'MAXIMUM' : IF (INDOPE.EQ.1) THEN DO j = 1, N VPOCHA(j,NC) = MIN( MPOVA1.VPOCHA(j,icour), XBMAX) ENDDO C- BORNER 'MINIMUM' : ELSE IF (INDOPE.EQ.2) THEN DO j = 1, N VPOCHA(j,NC) = MAX( MPOVA1.VPOCHA(j,icour), XBMIN) ENDDO C- BORNER 'COMPRIS' : ELSE IF (INDOPE.EQ.3) THEN DO j = 1, N x = MIN( MPOVA1.VPOCHA(j,icour), XBMAX) VPOCHA(j,NC) = MAX( x, XBMIN) ENDDO ELSE CALL ERREUR(5) ENDIF ENDIF C*100 CONTINUE ENDDO IF (NC.NE.0) THEN IRETS = IRETS + 1 IF (NC.NE.NCOMP) THEN SEGADJ,MPOVAL,MSOUPO ENDIF IPCHP(IRETS) = MSOUPO IPOVAL = MPOVAL ELSE SEGSUP,MPOVAL,MSOUPO ENDIF ENDDO IF (IRETS.GT.0) THEN IF (IRETS.NE.NSOUPO) THEN NSOUPO = IRETS NAT = JATTRI(/1) SEGADJ,MCHPOI ENDIF IPCHPS = MCHPOI ELSE CALL ERREUR(280) ENDIF 900 CONTINUE IF (IPCHPS.EQ.0) SEGSUP,MCHPOI RETURN END