Changeset 5082 for LMDZ6/branches/Amaury_dev/libf/misc
- Timestamp:
- Jul 19, 2024, 5:41:58 PM (17 months ago)
- Location:
- LMDZ6/branches/Amaury_dev/libf/misc
- Files:
-
- 16 edited
-
chfev.F (modified) (2 diffs)
-
formcoord.F (modified) (2 diffs)
-
i1mach.F (modified) (1 diff)
-
ismax.F (modified) (1 diff)
-
ismin.F (modified) (1 diff)
-
juldate.F (modified) (1 diff)
-
pchdf.F (modified) (1 diff)
-
pchfe.F (modified) (10 diffs)
-
pchsp.F (modified) (13 diffs)
-
q_sat.F (modified) (1 diff)
-
ran1.F (modified) (2 diffs)
-
sort.F (modified) (2 diffs)
-
xermsg.F (modified) (11 diffs)
-
xerprn.F (modified) (11 diffs)
-
xersve.F (modified) (6 diffs)
-
xgetua.F (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/Amaury_dev/libf/misc/chfev.F
r1907 r5082 100 100 C 101 101 C***FIRST EXECUTABLE STATEMENT CHFEV 102 IF (NE .LT.1) GO TO 5001102 IF (NE < 1) GO TO 5001 103 103 H = X2 - X1 104 IF (H .EQ.ZERO) GO TO 5002104 IF (H == ZERO) GO TO 5002 105 105 C 106 106 C INITIALIZE. … … 128 128 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) 129 129 C COUNT EXTRAPOLATION POINTS. 130 IF ( X .LT.XMI ) NEXT(1) = NEXT(1) + 1131 IF ( X .GT.XMA ) NEXT(2) = NEXT(2) + 1130 IF ( X<XMI ) NEXT(1) = NEXT(1) + 1 131 IF ( X>XMA ) NEXT(2) = NEXT(2) + 1 132 132 C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 133 133 500 CONTINUE -
LMDZ6/branches/Amaury_dev/libf/misc/formcoord.F
r1907 r5082 25 25 endif 26 26 27 if (n .lt.2) then27 if (n<2) then 28 28 ndec=1 29 29 write(unit,1000) text,n,x(1)*a … … 32 32 do i=2,n-1 33 33 dx=abs(x(i+1)-x(i)) 34 if (dx .lt.dxmin) dxmin=dx34 if (dx<dxmin) dxmin=dx 35 35 enddo 36 36 37 37 ndec=-log10(dxmin)+2 38 if(mod(n,6) .eq.1) then38 if(mod(n,6)==1) then 39 39 write(unit,1000) text,n,x(i1)*a 40 40 write(unit,2000) (x(i)*a,i=i2,in,id) -
LMDZ6/branches/Amaury_dev/libf/misc/i1mach.F
r2197 r5082 114 114 IMACH(15) = minexponent(0d0) 115 115 IMACH(16) = maxexponent(0d0) 116 IF (I .LT. 1 .OR. I .GT.16) GO TO 10116 IF (I < 1 .OR. I > 16) GO TO 10 117 117 C 118 118 I1MACH = IMACH(I) -
LMDZ6/branches/Amaury_dev/libf/misc/ismax.F
r1907 r5082 14 14 do 10 i=1,n-1 15 15 ix=ix+incx 16 if(sx(ix) .gt.sxmax) then16 if(sx(ix)>sxmax) then 17 17 sxmax=sx(ix) 18 18 ismax=i+1 -
LMDZ6/branches/Amaury_dev/libf/misc/ismin.F
r1907 r5082 14 14 DO i=1,n-1 15 15 ix=ix+incx 16 if(sx(ix) .lt.sxmin) then16 if(sx(ix)<sxmin) then 17 17 sxmin=sx(ix) 18 18 ismin=i+1 -
LMDZ6/branches/Amaury_dev/libf/misc/juldate.F
r2239 r5082 18 18 year=dble(ian) 19 19 rmon=dble(imoi) 20 if (imoi .le.2) then20 if (imoi <= 2) then 21 21 year=year-1. 22 22 rmon=rmon+12. 23 23 endif 24 24 cf=year+(rmon/100.)+(ojou/10000.) 25 if (cf .ge.1582.1015) then25 if (cf >= 1582.1015) then 26 26 a=int(year/100) 27 27 b=2-a+int(a/4) -
LMDZ6/branches/Amaury_dev/libf/misc/pchdf.F
r1907 r5082 72 72 C 73 73 C***FIRST EXECUTABLE STATEMENT PCHDF 74 IF (K .LT.3) GO TO 500174 IF (K < 3) GO TO 5001 75 75 C 76 76 C COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. -
LMDZ6/branches/Amaury_dev/libf/misc/pchfe.F
r1907 r5082 143 143 IF (SKIP) GO TO 5 144 144 C 145 IF ( N .LT.2 ) GO TO 5001146 IF ( INCFD .LT.1 ) GO TO 5002145 IF ( N<2 ) GO TO 5001 146 IF ( INCFD<1 ) GO TO 5002 147 147 DO 1 I = 2, N 148 IF ( X(I) .LE.X(I-1) ) GO TO 5003148 IF ( X(I)<=X(I-1) ) GO TO 5003 149 149 1 CONTINUE 150 150 C … … 152 152 C 153 153 5 CONTINUE 154 IF ( NE .LT.1 ) GO TO 5004154 IF ( NE<1 ) GO TO 5004 155 155 IERR = 0 156 156 SKIP = .TRUE. … … 164 164 C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. 165 165 C 166 IF (JFIRST .GT.NE) GO TO 5000166 IF (JFIRST > NE) GO TO 5000 167 167 C 168 168 C LOCATE ALL POINTS IN INTERVAL. 169 169 C 170 170 DO 20 J = JFIRST, NE 171 IF (XE(J) .GE.X(IR)) GO TO 30171 IF (XE(J) >= X(IR)) GO TO 30 172 172 20 CONTINUE 173 173 J = NE + 1 … … 177 177 C 178 178 30 CONTINUE 179 IF (IR .EQ.N) J = NE + 1179 IF (IR == N) J = NE + 1 180 180 C 181 181 40 CONTINUE … … 184 184 C SKIP EVALUATION IF NO POINTS IN INTERVAL. 185 185 C 186 IF (NJ .EQ.0) GO TO 50186 IF (NJ == 0) GO TO 50 187 187 C 188 188 C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . … … 192 192 * NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) 193 193 C ---------------------------------------------------------------- 194 IF (IERC .LT.0) GO TO 5005195 C 196 IF (NEXT(2) .EQ.0) GO TO 42194 IF (IERC < 0) GO TO 5005 195 C 196 IF (NEXT(2) == 0) GO TO 42 197 197 C IF (NEXT(2) .GT. 0) THEN 198 198 C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE 199 199 C RIGHT OF X(IR). 200 200 C 201 IF (IR .LT.N) GO TO 41201 IF (IR < N) GO TO 41 202 202 C IF (IR .EQ. N) THEN 203 203 C THESE ARE ACTUALLY EXTRAPOLATION POINTS. … … 212 212 42 CONTINUE 213 213 C 214 IF (NEXT(1) .EQ.0) GO TO 49214 IF (NEXT(1) == 0) GO TO 49 215 215 C IF (NEXT(1) .GT. 0) THEN 216 216 C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE 217 217 C LEFT OF X(IR-1). 218 218 C 219 IF (IR .GT.2) GO TO 43219 IF (IR > 2) GO TO 43 220 220 C IF (IR .EQ. 2) THEN 221 221 C THESE ARE ACTUALLY EXTRAPOLATION POINTS. … … 229 229 C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). 230 230 DO 44 I = JFIRST, J-1 231 IF (XE(I) .LT.X(IR-1)) GO TO 45231 IF (XE(I) < X(IR-1)) GO TO 45 232 232 44 CONTINUE 233 233 C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR … … 241 241 C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. 242 242 DO 46 I = 1, IR-1 243 IF (XE(J) .LT.X(I)) GO TO 47243 IF (XE(J) < X(I)) GO TO 47 244 244 46 CONTINUE 245 245 C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). … … 261 261 50 CONTINUE 262 262 IR = IR + 1 263 IF (IR .LE.N) GO TO 10263 IF (IR <= N) GO TO 10 264 264 C 265 265 C NORMAL RETURN. -
LMDZ6/branches/Amaury_dev/libf/misc/pchsp.F
r1907 r5082 162 162 C 163 163 C***FIRST EXECUTABLE STATEMENT PCHSP 164 IF ( N .LT.2 ) GO TO 5001165 IF ( INCFD .LT.1 ) GO TO 5002164 IF ( N<2 ) GO TO 5001 165 IF ( INCFD<1 ) GO TO 5002 166 166 DO 1 J = 2, N 167 IF ( X(J) .LE.X(J-1) ) GO TO 5003167 IF ( X(J)<=X(J-1) ) GO TO 5003 168 168 1 CONTINUE 169 169 C … … 171 171 IEND = IC(2) 172 172 IERR = 0 173 IF ( (IBEG .LT.0).OR.(IBEG.GT.4) ) IERR = IERR - 1174 IF ( (IEND .LT.0).OR.(IEND.GT.4) ) IERR = IERR - 2175 IF ( IERR .LT.0 ) GO TO 5004173 IF ( (IBEG<0).OR.(IBEG>4) ) IERR = IERR - 1 174 IF ( (IEND<0).OR.(IEND>4) ) IERR = IERR - 2 175 IF ( IERR<0 ) GO TO 5004 176 176 C 177 177 C FUNCTION DEFINITION IS OK -- GO ON. 178 178 C 179 IF ( NWK .LT.2*N ) GO TO 5007179 IF ( NWK < 2*N ) GO TO 5007 180 180 C 181 181 C COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, … … 188 188 C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. 189 189 C 190 IF ( IBEG .GT.N ) IBEG = 0191 IF ( IEND .GT.N ) IEND = 0190 IF ( IBEG>N ) IBEG = 0 191 IF ( IEND>N ) IEND = 0 192 192 C 193 193 C SET UP FOR BOUNDARY CONDITIONS. 194 194 C 195 IF ( (IBEG .EQ.1).OR.(IBEG.EQ.2) ) THEN195 IF ( (IBEG==1).OR.(IBEG==2) ) THEN 196 196 D(1,1) = VC(1) 197 ELSE IF (IBEG .GT.2) THEN197 ELSE IF (IBEG > 2) THEN 198 198 C PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. 199 199 DO 10 J = 1, IBEG … … 201 201 C INDEX RUNS FROM IBEG DOWN TO 1. 202 202 XTEMP(J) = X(INDEX) 203 IF (J .LT.IBEG) STEMP(J) = WK(2,INDEX)203 IF (J < IBEG) STEMP(J) = WK(2,INDEX) 204 204 10 CONTINUE 205 205 C -------------------------------- 206 206 D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR) 207 207 C -------------------------------- 208 IF (IERR .NE.0) GO TO 5009208 IF (IERR /= 0) GO TO 5009 209 209 IBEG = 1 210 210 ENDIF 211 211 C 212 IF ( (IEND .EQ.1).OR.(IEND.EQ.2) ) THEN212 IF ( (IEND==1).OR.(IEND==2) ) THEN 213 213 D(1,N) = VC(2) 214 ELSE IF (IEND .GT.2) THEN214 ELSE IF (IEND > 2) THEN 215 215 C PICK UP LAST IEND POINTS. 216 216 DO 15 J = 1, IEND … … 218 218 C INDEX RUNS FROM N+1-IEND UP TO N. 219 219 XTEMP(J) = X(INDEX) 220 IF (J .LT.IEND) STEMP(J) = WK(2,INDEX+1)220 IF (J < IEND) STEMP(J) = WK(2,INDEX+1) 221 221 15 CONTINUE 222 222 C -------------------------------- 223 223 D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR) 224 224 C -------------------------------- 225 IF (IERR .NE.0) GO TO 5009225 IF (IERR /= 0) GO TO 5009 226 226 IEND = 1 227 227 ENDIF … … 237 237 C WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) 238 238 C 239 IF (IBEG .EQ.0) THEN240 IF (N .EQ.2) THEN239 IF (IBEG == 0) THEN 240 IF (N == 2) THEN 241 241 C NO CONDITION AT LEFT END AND N = 2. 242 242 WK(2,1) = ONE … … 250 250 * + WK(1,2)**2*WK(2,3)) / WK(1,1) 251 251 ENDIF 252 ELSE IF (IBEG .EQ.1) THEN252 ELSE IF (IBEG == 1) THEN 253 253 C SLOPE PRESCRIBED AT LEFT END. 254 254 WK(2,1) = ONE … … 266 266 C 267 267 NM1 = N-1 268 IF (NM1 .GT.1) THEN268 IF (NM1 > 1) THEN 269 269 DO 20 J=2,NM1 270 IF (WK(2,J-1) .EQ.ZERO) GO TO 5008270 IF (WK(2,J-1) == ZERO) GO TO 5008 271 271 G = -WK(1,J+1)/WK(2,J-1) 272 272 D(1,J) = G*D(1,J-1) … … 282 282 C SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT 283 283 C AT THIS POINT. 284 IF (IEND .EQ.1) GO TO 30285 C 286 IF (IEND .EQ.0) THEN287 IF (N .EQ.2 .AND. IBEG.EQ.0) THEN284 IF (IEND == 1) GO TO 30 285 C 286 IF (IEND == 0) THEN 287 IF (N==2 .AND. IBEG==0) THEN 288 288 C NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. 289 289 D(1,2) = WK(2,2) 290 290 GO TO 30 291 ELSE IF ((N .EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0)) THEN291 ELSE IF ((N==2) .OR. (N==3 .AND. IBEG==0)) THEN 292 292 C EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* 293 293 C NOT-A-KNOT AT LEFT END POINT). 294 294 D(1,N) = TWO*WK(2,N) 295 295 WK(2,N) = ONE 296 IF (WK(2,N-1) .EQ.ZERO) GO TO 5008296 IF (WK(2,N-1) == ZERO) GO TO 5008 297 297 G = -ONE/WK(2,N-1) 298 298 ELSE … … 303 303 D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) 304 304 * + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G 305 IF (WK(2,N-1) .EQ.ZERO) GO TO 5008305 IF (WK(2,N-1) == ZERO) GO TO 5008 306 306 G = -G/WK(2,N-1) 307 307 WK(2,N) = WK(1,N-1) … … 311 311 D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) 312 312 WK(2,N) = TWO 313 IF (WK(2,N-1) .EQ.ZERO) GO TO 5008313 IF (WK(2,N-1) == ZERO) GO TO 5008 314 314 G = -ONE/WK(2,N-1) 315 315 ENDIF … … 318 318 C 319 319 WK(2,N) = G*WK(1,N-1) + WK(2,N) 320 IF (WK(2,N) .EQ.ZERO) GO TO 5008320 IF (WK(2,N) == ZERO) GO TO 5008 321 321 D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) 322 322 C … … 325 325 30 CONTINUE 326 326 DO 40 J=NM1,1,-1 327 IF (WK(2,J) .EQ.ZERO) GO TO 5008327 IF (WK(2,J) == ZERO) GO TO 5008 328 328 D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) 329 329 40 CONTINUE -
LMDZ6/branches/Amaury_dev/libf/misc/q_sat.F
r2342 r5082 52 52 ! write(*,*)'temp,pres=',temp(ip),pres(ip) 53 53 ! 54 IF (temp(ip) .LE.rtt) THEN54 IF (temp(ip) <= rtt) THEN 55 55 r3es = r3ies 56 56 r4es = r4ies -
LMDZ6/branches/Amaury_dev/libf/misc/ran1.F
r2239 r5082 14 14 INTEGER :: IDUM,J 15 15 16 IF (IDUM .LT.0.OR.IFF.EQ.0) THEN16 IF (IDUM<0.OR.IFF==0) THEN 17 17 IFF=1 18 18 IX1=MOD(IC1-IDUM,M1) … … 32 32 IX3=MOD(IA3*IX3+IC3,M3) 33 33 J=1+(97*IX3)/M3 34 IF(J .GT.97.OR.J.LT.1) stop 134 IF(J>97.OR.J<1) stop 1 35 35 RAN1=R(J) 36 36 R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 -
LMDZ6/branches/Amaury_dev/libf/misc/sort.F
r2239 r5082 22 22 p=d(i) 23 23 DO j=i+1,n 24 IF(d(j) .LE.p) THEN24 IF(d(j)<=p) THEN 25 25 k=j 26 26 p=d(j) … … 28 28 ENDDO 29 29 30 IF(k .ne.i) THEN30 IF(k/=i) THEN 31 31 d(k)=d(i) 32 32 d(i)=p -
LMDZ6/branches/Amaury_dev/libf/misc/xermsg.F
r2197 r5082 205 205 C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. 206 206 C 207 IF (NERR .LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.208 * LEVEL .LT.-1 .OR. LEVEL.GT.2) THEN207 IF (NERR<-9999999 .OR. NERR>99999999 .OR. NERR==0 .OR. 208 * LEVEL<-1 .OR. LEVEL>2) THEN 209 209 CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // 210 210 * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// … … 222 222 C HANDLE PRINT-ONCE WARNING MESSAGES. 223 223 C 224 IF (LEVEL .EQ.-1 .AND. KOUNT.GT.1) RETURN224 IF (LEVEL==-1 .AND. KOUNT>1) RETURN 225 225 C 226 226 C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. … … 239 239 C ZERO AND THE ERROR IS NOT FATAL. 240 240 C 241 IF (LEVEL .LT.2 .AND. LKNTRL.EQ.0) GO TO 30242 IF (LEVEL .EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30243 IF (LEVEL .EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30244 IF (LEVEL .EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30241 IF (LEVEL<2 .AND. LKNTRL==0) GO TO 30 242 IF (LEVEL==0 .AND. KOUNT>MAXMES) GO TO 30 243 IF (LEVEL==1 .AND. KOUNT>MAXMES .AND. MKNTRL==1) GO TO 30 244 IF (LEVEL==2 .AND. KOUNT>MAX(1,MAXMES)) GO TO 30 245 245 C 246 246 C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A … … 249 249 C IS NOT ZERO. 250 250 C 251 IF (LKNTRL .NE.0) THEN251 IF (LKNTRL /= 0) THEN 252 252 TEMP(1:21) = 'MESSAGE FROM ROUTINE ' 253 253 I = MIN(LEN(SUBROU), 16) … … 281 281 C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. 282 282 C 283 IF (LKNTRL .GT.0) THEN283 IF (LKNTRL > 0) THEN 284 284 C 285 285 C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. 286 286 C 287 IF (LEVEL .LE.0) THEN287 IF (LEVEL <= 0) THEN 288 288 TEMP(1:20) = 'INFORMATIVE MESSAGE,' 289 289 LTEMP = 20 290 ELSEIF (LEVEL .EQ.1) THEN290 ELSEIF (LEVEL == 1) THEN 291 291 TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' 292 292 LTEMP = 30 … … 298 298 C THEN WHETHER THE PROGRAM WILL CONTINUE. 299 299 C 300 IF ((MKNTRL .EQ.2 .AND. LEVEL.GE.1) .OR.301 * (MKNTRL .EQ.1 .AND. LEVEL.EQ.2)) THEN300 IF ((MKNTRL==2 .AND. LEVEL>=1) .OR. 301 * (MKNTRL==1 .AND. LEVEL==2)) THEN 302 302 TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' 303 303 LTEMP = LTEMP + 14 … … 309 309 C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. 310 310 C 311 IF (LKNTRL .GT.0) THEN311 IF (LKNTRL > 0) THEN 312 312 TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' 313 313 LTEMP = LTEMP + 20 … … 326 326 C TRACEBACK. 327 327 C 328 IF (LKNTRL .GT.0) THEN328 IF (LKNTRL > 0) THEN 329 329 WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR 330 330 DO 10 I=16,22 331 IF (TEMP(I:I) .NE.' ') GO TO 20331 IF (TEMP(I:I) /= ' ') GO TO 20 332 332 10 CONTINUE 333 333 C … … 338 338 C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. 339 339 C 340 IF (LKNTRL .NE.0) THEN340 IF (LKNTRL /= 0) THEN 341 341 CALL XERPRN (' * ', -1, ' ', 72) 342 342 CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) … … 347 347 C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. 348 348 C 349 30 IF (LEVEL .LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN349 30 IF (LEVEL<=0 .OR. (LEVEL==1 .AND. MKNTRL<=1)) RETURN 350 350 C 351 351 C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A … … 353 353 C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. 354 354 C 355 IF (LKNTRL .GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN356 IF (LEVEL .EQ.1) THEN355 IF (LKNTRL>0 .AND. KOUNT<MAX(1,MAXMES)) THEN 356 IF (LEVEL == 1) THEN 357 357 CALL XERPRN 358 358 * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) -
LMDZ6/branches/Amaury_dev/libf/misc/xerprn.F
r2197 r5082 93 93 N = I1MACH(4) 94 94 DO 10 I=1,NUNIT 95 IF (IU(I) .EQ.0) IU(I) = N95 IF (IU(I) == 0) IU(I) = N 96 96 10 CONTINUE 97 97 C … … 100 100 C THE REST OF THIS ROUTINE. 101 101 C 102 IF ( NPREF .LT.0 ) THEN102 IF ( NPREF < 0 ) THEN 103 103 LPREF = LEN(PREFIX) 104 104 ELSE … … 106 106 ENDIF 107 107 LPREF = MIN(16, LPREF) 108 IF (LPREF .NE.0) CBUFF(1:LPREF) = PREFIX108 IF (LPREF /= 0) CBUFF(1:LPREF) = PREFIX 109 109 C 110 110 C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE … … 118 118 N = LENMSG 119 119 DO 20 I=1,N 120 IF (MESSG(LENMSG:LENMSG) .NE.' ') GO TO 30120 IF (MESSG(LENMSG:LENMSG) /= ' ') GO TO 30 121 121 LENMSG = LENMSG - 1 122 122 20 CONTINUE … … 125 125 C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. 126 126 C 127 IF (LENMSG .EQ.0) THEN127 IF (LENMSG == 0) THEN 128 128 CBUFF(LPREF+1:LPREF+1) = ' ' 129 129 DO 40 I=1,NUNIT … … 172 172 NEXTC = 1 173 173 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) 174 IF (LPIECE .EQ.0) THEN174 IF (LPIECE == 0) THEN 175 175 C 176 176 C THERE WAS NO NEW LINE SENTINEL FOUND. … … 178 178 IDELTA = 0 179 179 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) 180 IF (LPIECE .LT.LENMSG+1-NEXTC) THEN180 IF (LPIECE < LENMSG+1-NEXTC) THEN 181 181 DO 52 I=LPIECE+1,2,-1 182 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ.' ') THEN182 IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN 183 183 LPIECE = I-1 184 184 IDELTA = 1 … … 189 189 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) 190 190 NEXTC = NEXTC + LPIECE + IDELTA 191 ELSEIF (LPIECE .EQ.1) THEN191 ELSEIF (LPIECE == 1) THEN 192 192 C 193 193 C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). … … 196 196 NEXTC = NEXTC + 2 197 197 GO TO 50 198 ELSEIF (LPIECE .GT.LWRAP+1) THEN198 ELSEIF (LPIECE > LWRAP+1) THEN 199 199 C 200 200 C LPIECE SHOULD BE SET DOWN TO LWRAP. … … 203 203 LPIECE = LWRAP 204 204 DO 56 I=LPIECE+1,2,-1 205 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ.' ') THEN205 IF (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN 206 206 LPIECE = I-1 207 207 IDELTA = 1 … … 227 227 60 CONTINUE 228 228 C 229 IF (NEXTC .LE.LENMSG) GO TO 50229 IF (NEXTC <= LENMSG) GO TO 50 230 230 RETURN 231 231 END -
LMDZ6/branches/Amaury_dev/libf/misc/xersve.F
r2199 r5082 72 72 C***FIRST EXECUTABLE STATEMENT XERSVE 73 73 C 74 IF (KFLAG .LE.0) THEN74 IF (KFLAG<=0) THEN 75 75 C 76 76 C Dump the table. 77 77 C 78 IF (NMSG .EQ.0) RETURN78 IF (NMSG==0) RETURN 79 79 C 80 80 C Print to each unit. … … 83 83 DO 20 KUNIT = 1,NUNIT 84 84 IUNIT = LUN(KUNIT) 85 IF (IUNIT .EQ.0) IUNIT = I1MACH(4)85 IF (IUNIT==0) IUNIT = I1MACH(4) 86 86 C 87 87 C Print the table header. … … 98 98 C Print number of other errors. 99 99 C 100 IF (KOUNTX .NE.0) WRITE (IUNIT,9020) KOUNTX100 IF (KOUNTX/=0) WRITE (IUNIT,9020) KOUNTX 101 101 WRITE (IUNIT,9030) 102 102 20 CONTINUE … … 104 104 C Clear the error tables. 105 105 C 106 IF (KFLAG .EQ.0) THEN106 IF (KFLAG==0) THEN 107 107 NMSG = 0 108 108 KOUNTX = 0 … … 118 118 MES = MESSG 119 119 DO 30 I = 1,NMSG 120 IF (LIB .EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND.121 * MES .EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND.122 * LEVEL .EQ.LEVTAB(I)) THEN120 IF (LIB==LIBTAB(I) .AND. SUB==SUBTAB(I) .AND. 121 * MES==MESTAB(I) .AND. NERR==NERTAB(I) .AND. 122 * LEVEL==LEVTAB(I)) THEN 123 123 KOUNT(I) = KOUNT(I) + 1 124 124 ICOUNT = KOUNT(I) … … 127 127 30 CONTINUE 128 128 C 129 IF (NMSG .LT.LENTAB) THEN129 IF (NMSG<LENTAB) THEN 130 130 C 131 131 C Empty slot found for new message. -
LMDZ6/branches/Amaury_dev/libf/misc/xgetua.F
r2197 r5082 47 47 DO 30 I=1,N 48 48 INDEX = I+4 49 IF (I .EQ.1) INDEX = 349 IF (I==1) INDEX = 3 50 50 IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) 51 51 30 CONTINUE
Note: See TracChangeset
for help on using the changeset viewer.
