1 : C PUCHER SOURCE BP208322 12/05/24 21:15:03 7378 2 : SUBROUTINE PUCHER(IPCHE1,XPU,IPCHPU,IRET) 3 : *_______________________________________________________________________ 4 : * 5 : * ELEVATION A UNE PUISSANCE REEL D'UN CHAMELEM 6 : * 7 : * ENTREES : 8 : * --------- 9 : * 10 : * IPCHE1 POINTEUR SUR LE CHAMPS PAR ELEMENT A ELEVER A LA PUISSANCE 11 : * XPU 12 : * XPU PUISSANCE ( C EST UN REEL POSITIF OU NEGATIF ) 13 : * 14 : * 15 : * SORTIES : 16 : * --------- 17 : * 18 : * IPCHPU POINTEUR SUR LE CHAMELEM RESULTANT 19 : * IPCHPU =0 SI PB 20 : * IRET=1 21 : * =0 SI UNE COMPOSANTE EST NEGATIVE 22 : * 23 : * CODE EBERSOLT AVRIL 85 24 : * 25 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12/90 26 : * 27 : *_______________________________________________________________________ 28 : * 29 : IMPLICIT INTEGER(I-N) 30 : IMPLICIT REAL*8(A-H,O-Z) 31 : * 32 : -INC SMCHAML 33 : -INC CCOPTIO 34 : -INC SMLREEL 35 : * 36 : IRET=1 37 : MCHEL1=IPCHE1 38 : * 39 : * INITIALISATION DU CHAPEAU DU SEGMENT 40 : * 41 : SEGINI,MCHELM=MCHEL1 42 : IPCHPU=MCHELM 43 : NSOUS=ICHAML(/1) 44 : 45 : C ON ORIENTE SELON LA VALEUR DE XPU (PERFORMANCES) 46 : if(XPU.eq.0.5d0) goto 100 47 : 48 : 49 : c---------------------------------------------------------------------- 50 : c Cas général Y**XPU 51 : * 52 : * BOUCLE SUR LES SOUS ZONES 53 : * 54 : DO 30 ISOUS=1,NSOUS 55 : MCHAM1=ICHAML(ISOUS) 56 : SEGINI,MCHAML=MCHAM1 57 : ICHAML(ISOUS)=MCHAML 58 : DO 40 ICOMP=1,IELVAL(/1) 59 : MELVA1=IELVAL(ICOMP) 60 : SEGINI,MELVAL=MELVA1 61 : IELVAL(ICOMP)=MELVAL 62 : IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN 63 : N1PTEL=VELCHE(/1) 64 : N1EL =VELCHE(/2) 65 : DO 20 IB=1,N1EL 66 : DO 20 IGAU=1,N1PTEL 67 : XTRA=VELCHE(IGAU,IB) 68 : IF( XTRA.LT.0.) IRET = 0 69 : IF( XTRA.LE.0.) VELCHE(IGAU,IB)= 0. 70 : IF( XTRA.GT.0.) VELCHE(IGAU,IB)= XTRA ** XPU 71 : 20 CONTINUE 72 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 73 : N2PTEL=IELCHE(/1) 74 : N2EL =IELCHE(/2) 75 : DO 10 IB=1,N2EL 76 : DO 10 IGAU=1,N2PTEL 77 : MLREE1=IELCHE(IGAU,IB) 78 : SEGACT MLREE1 79 : JG=MLREE1.PROG(/1) 80 : SEGINI MLREEL 81 : DO 11 IPROG=1,JG 82 : XTRA=MLREE1.PROG(IPROG) 83 : IF( XTRA.LT.0.) IRET = 0 84 : IF( XTRA.LE.0.) PROG(IPROG)= 0. 85 : IF( XTRA.GT.0.) PROG(IPROG)= XTRA ** XPU 86 : 11 CONTINUE 87 : IELCHE(IGAU,IB)=MLREEL 88 : SEGDES MLREE1,MLREEL 89 : 10 CONTINUE 90 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN 91 : N2PTEL=IELCHE(/1) 92 : N2EL =IELCHE(/2) 93 : DO 12 IB=1,N2EL 94 : DO 12 IGAU=1,N2PTEL 95 : MEVOL1=IELCHE(IGAU,IB) 96 : IRET=2 96 : CALL PUEVOL(MEVOL1,XPU,0,MEVOL2,IRET) 97 : IELCHE(IGAU,IB)=MEVOL2 98 : 12 CONTINUE 99 : ELSE 100 : * 101 : * NOM DE COMPOSANTE NON RECONNU 102 : * 103 : MOTERR(1:4)='** ' 104 : MOTERR(5:8)=NOMCHE(ICOMP) 104 : CALL ERREUR(335) 105 : SEGSUP MELVAL,MCHAML,MCHELM 106 : IPCHPU=0 107 : RETURN 108 : ENDIF 109 : SEGDES MELVAL 110 : 40 CONTINUE 111 : SEGDES MCHAML 112 : 30 CONTINUE 113 : GOTO 999 114 : 115 : 116 : c---------------------------------------------------------------------- 117 : c Cas : Y**0.5 118 : 100 CONTINUE 119 : * 120 : * BOUCLE SUR LES SOUS ZONES 121 : * 122 : DO 130 ISOUS=1,NSOUS 123 : MCHAM1=ICHAML(ISOUS) 124 : SEGINI,MCHAML=MCHAM1 125 : ICHAML(ISOUS)=MCHAML 126 : DO 140 ICOMP=1,IELVAL(/1) 127 : MELVA1=IELVAL(ICOMP) 128 : SEGINI,MELVAL=MELVA1 129 : IELVAL(ICOMP)=MELVAL 130 : IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN 131 : N1PTEL=VELCHE(/1) 132 : N1EL =VELCHE(/2) 133 : DO 120 IB=1,N1EL 134 : DO 120 IGAU=1,N1PTEL 135 : XTRA=VELCHE(IGAU,IB) 136 : IF( XTRA.LT.0.) IRET = 0 137 : IF( XTRA.LE.0.) VELCHE(IGAU,IB)= 0. 138 : IF( XTRA.GT.0.) VELCHE(IGAU,IB)= sqrt(XTRA) 139 : 120 CONTINUE 140 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 141 : N2PTEL=IELCHE(/1) 142 : N2EL =IELCHE(/2) 143 : DO 110 IB=1,N2EL 144 : DO 110 IGAU=1,N2PTEL 145 : MLREE1=IELCHE(IGAU,IB) 146 : SEGACT MLREE1 147 : JG=MLREE1.PROG(/1) 148 : SEGINI MLREEL 149 : DO 111 IPROG=1,JG 150 : XTRA=MLREE1.PROG(IPROG) 151 : IF( XTRA.LT.0.) IRET = 0 152 : IF( XTRA.LE.0.) PROG(IPROG)= 0. 153 : IF( XTRA.GT.0.) PROG(IPROG)= sqrt(XTRA) 154 : 111 CONTINUE 155 : IELCHE(IGAU,IB)=MLREEL 156 : SEGDES MLREE1,MLREEL 157 : 110 CONTINUE 158 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN 159 : N2PTEL=IELCHE(/1) 160 : N2EL =IELCHE(/2) 161 : DO 112 IB=1,N2EL 162 : DO 112 IGAU=1,N2PTEL 163 : MEVOL1=IELCHE(IGAU,IB) 164 : IRET=2 164 : CALL PUEVOL(MEVOL1,XPU,0,MEVOL2,IRET) 165 : IELCHE(IGAU,IB)=MEVOL2 166 : 112 CONTINUE 167 : ELSE 168 : * 169 : * NOM DE COMPOSANTE NON RECONNU 170 : * 171 : MOTERR(1:4)='** ' 172 : MOTERR(5:8)=NOMCHE(ICOMP) 172 : CALL ERREUR(335) 173 : SEGSUP MELVAL,MCHAML,MCHELM 174 : IPCHPU=0 175 : RETURN 176 : ENDIF 177 : SEGDES MELVAL 178 : 140 CONTINUE 179 : SEGDES MCHAML 180 : 130 CONTINUE 181 : GOTO 999 182 : 183 : 184 : 185 : c---------------------------------------------------------------------- 186 : c FIN DU PROGRAMME 187 : 999 CONTINUE 188 : SEGDES MCHELM 189 : RETURN 190 : END 191 : 192 : 193 : 194 : 195 :
© Cast3M 2003 - All rights reserved.
Disclaimer