From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- sys/gio/ncarutil/conlib/conecd.f | 178 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 sys/gio/ncarutil/conlib/conecd.f (limited to 'sys/gio/ncarutil/conlib/conecd.f') diff --git a/sys/gio/ncarutil/conlib/conecd.f b/sys/gio/ncarutil/conlib/conecd.f new file mode 100644 index 00000000..56d8a934 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conecd.f @@ -0,0 +1,178 @@ + SUBROUTINE CONECD (VAL,IOUT,NUSED) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C ENCODE A NUMBER IN THE LEAST AMOUNT OF SPACE +C ON INPUT +C VAL THE NUMBER TO BE ENCODED +C ON OUTPUT +C IOUT CHARACTER STRING FILLED WITH THE ENCODED RESULT, MUST BE ABLE TO +C HOLD UP TO 9 CHARACTERS. +C +C NUSED NUMBER OF CHARACTERS IN IOUT +C +C VALUE INPUT WILL BE SCALED BY SCALE IN CONRA2 +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + CHARACTER*(*) IOUT + CHARACTER*6 IFMT1 +C +C +NOAO - Variables CHTMP and IT are not used. +C +C CHARACTER*9 CHTMP +C CHARACTER*1 IT +C +C -NOAO +C + SAVE +C + V = VAL +C +C IF VAL EQUALS ZERO EASY PROCESSING +C + IF (V.NE.0.) GO TO 20 + IOUT = '0.0' + NUSED = 3 + RETURN +C +C SCALE VALUE +C + 20 V = V*SCALE +C +C GET SIZE OF NUMBER +C + LOG = IFIX(ALOG10(ABS(V))+.1) + IF (IABS(LOG).GT.4) GO TO 60 +C +C COMPUTE FLOATING POINT FIELD +C + NS = IABS(LOG)+3 + ND = 1 + IF (LOG.GT.0) GO TO 40 +C +C LOG = 0 TEST FOR FRACTIONAL PART ONLY +C + IF (ALOG10( ABS(V) ).GE.0.) GO TO 30 +C +C NUMBER LT 1 BUT GREATER THAN ZERO IN ABSOLUTE VALUE +C + NS = 4 + ND = 1 + GO TO 40 +C +C NUMBER LESS THAN 10 BUT GE 1 +C + 30 ND = 1 + NS = 4 +C +C BUILD THE FORMAT +C + 40 IF (V.LT.0) NS = NS+1 + IFMT1 = '(F . )' +C +C INSERT THE FLOATING POINT FORMAT SIZE +C +C +NOAO - Scheme for creating format has been modified because it uses +C FTN internal writes. NOAO mods are written in lower case. +C +C WRITE(IT,'(I1)')NS +C IFMT1(3:3) = IT +C WRITE(IT,'(I1)')ND +C IFMT1(5:5) = IT +C + ifmt1(1:6) = '(f . )' + ifmt1(3:3) = char (ns + ichar ('0') + 1) + ifmt1(5:5) = char (nd + ichar ('0')) +C +C ENCODE THE DESIRED NUMBER +C +C WRITE(CHTMP,IFMT1)V +C IOUT = CHTMP +C + call encode (ns, ifmt1, iout, v) + + NUSED = NS + RETURN +C +C DATA LARGER THAN A NICE SIZE FORCE IT TO BE ENCODED +C +C 60 WRITE(CHTMP,'(E8.3)')V +C IOUT = CHTMP +C + 60 call encode (8, '(E8.3)', iout, v) +C +C -NOAO + NUSED = 8 + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONCOM TO ULIB * +C* AUGUST 1980 FIXED BOARDER CONTOUR DETECTION * +C* DECEMBER 1980 FIXED ERROR TRAP, CONTOUR REORDERING ALGORITHM * +C* AND ERROR MESSAGE 10 * +C* AUGUST 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED (MACHINE DEPENDENT) FUNCTION LOC; CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END -- cgit