*RTN [INTERFACE]:
*     INTERFACE TO INTEGER*2 FUNCTION SYSTEM [C] (STRING)
*     CHARACTER*1 STRING[REFERENCE]
*     END ! [INTERFACE]
*RTN MEDIR:
*
* Programmed copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
* Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Updated by PJK 13 AUG 1993
*
* Revised copyright (C) Richard L Holmes, Tucson, Arizona, USA, 30 NOV 1994
* Modified (C) by RLH 16 JAN 1996
*
* * * * T H I S   C O P Y   H A S   B E E N   H A C K E D   A R O U N D
* 
* * * *     B Y   M A R T I N   M U N R O  :   D O   N O T
*                                                   =======
* * * *     D I S T R I B U T E   I N   A N Y   F O R M   W I T H O U T
*
* * * *     C O N S U L T I N G   R I C H A R D   H O L M E S .
*
* This program requires MS DOS 3.0 or newer and is adapted for
* METRONICS QUICK-CHEK display systems.
*
* MXD . . . maximum number of measurements in series
* 
* /RARR/. . storage for measurement values
*    RM1. . .  new measurement values
*    RM2. . .  used for input of values from an existing file
*
* /FLINFO/. file information
*    IUR. . .  unit number for measurement file
*    IUB. . .  unit number for creating backup copy
*    Q20. . .  file name
*    QID. . .  series identification
*    QQNA . .  'N' = new file, 'A' = append to existing file
*    QQ32 . .  '3' = .001 mm precision, '2' = .01 mm precision
*    QCM. . .  'N' = new series, 'C' = continue partially measured one
*    QRM. . .  'N' = remeasure part, 'Y' = remeasure all, ' ' = ????
*
* /CMINFO/. com port information (connection to Metronics Quick-Chek)
*    IUC. . .  unit number for com port
*    CUML . .  previous absolute measurement read from the port
*    QCOM . .  MS-DOS COM device number ('1' = COM1:, '2' = COM2: &c.)
*
* /DATES/ . dating information for the measurement series
*    NYR. . .  number of years in the series
*    JYR. . .  date of the first measurement
*    LYR. . .  date of the last measurement
*    LYRM . .  date of end of measurement series before remeasurement
*
* DONE. . . no more series to measure
* MORE. . . more of the current series to measure
* OK. . . . OK to modify an existing file, or a newly-created file
* NOSLCT. . user needs to select from the menu to continue measuring
*
* QX. . . . 'N' = display disclaimer menu option, ' ' = don't display
* QRS . . . ' ' = user has finished using the setup menu
* I . . . . result of MS-DOS system call (not tested)
* 
*     PROGRAM MEDIR
*
      IMPLICIT CHARACTER(Q)
      PARAMETER (MXD = 2048)
      COMMON /RARR/ RM1(MXD), RM2(MXD)
      COMMON /FLINFO/ IUR, IUB, Q20, QID, QQNA, QQ32, QCM, QRM
      COMMON /CMINFO/ IUC, CUML, QCOM
      COMMON /DATES/ NYR, JYR, LYR, LYRM
      CHARACTER QID*8, Q20*20
      LOGICAL DONE, MORE, OK, NOSLCT
*
      IUC = 10
      IUR = 11
      IUB = 12
      QQNA = 'N'
      QQ32 = '3'
      QX   = 'N'
      QCOM = '2'
      DONE = .FALSE.
      OK   = .FALSE.
   10 CONTINUE
   20    CONTINUE
         IF (OK) GOTO 40
   30       CONTINUE
               CALL MENU1(QX, QQNA, QQ32, QCOM, QRS)
            IF (QRS .NE. ' ') GOTO 30
            CALL DOFILE
            CALL PRPFIL(OK)
            GOTO 20
   40    CONTINUE
         CALL NXTRNG(LYR + 1)
*        1200 baud, No parity, 8 data, 2 stop bits, retry sending...
         CALL SETCOM(QCOM)
*        Open COM port to read values....
*        CALL OPENFI(IUC, 'COM'//QCOM, 'O')
         CUML = 0
   50    CONTINUE
            CALL MESURE
   60       CONTINUE
               CALL INMENU(NOSLCT, MORE, DONE)
            IF (NOSLCT) GOTO 60
         IF (MORE) GOTO 50
         IF (.NOT. DONE) CALL PRPFIL(OK)
      IF (.NOT. DONE) GOTO 10
      WRITE(*,'('' Measurements in file '',A)') Q20
      CALL SALE('Tree ))))))))))) Rings!')
      END ! MEDIR
*RTN MESURE: Read measurements values from the com port
*
* Because the measuring machine sends absolute distances from an
* arbitrary origin, we need the difference between the current
* measurement, CUMV, and the previous one, CUML, to find the ring
* width, RWM.  Negative differences (produced when the user moves the
* stage backwards) stop the sequence of measurements.
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE MESURE
*
      IMPLICIT CHARACTER(Q)
*
      PARAMETER (MXD = 2048)
      COMMON /RARR/ RM1(MXD), RM2(MXD)
      COMMON /CMINFO/ IUC, CUML, QCOM
      COMMON /DATES/ NYR, JYR, LYR, LYRM
      CHARACTER CHAR, Q16*16
*
      WRITE(*,'(1X,A,''[16C'',$)') CHAR(27)
   10 CONTINUE
*        READ(IUC,'(A/)') Q16
         CALL GETCOM(QCOM, Q16)
         READ(Q16,'(1X,F10.3)') CUMV
*## Diag         CALL COMLOG(Q16, 'Data')
         RWM = CUMV - CUML
         IF (RWM .GE. 0.) THEN
            NYR = NYR + 1
            LYR = LYR + 1
            RM1(NYR) = RWM
            CUML = CUMV
*           Beep on decade; note ring measurement....
            IF (MOD((LYR),10) .EQ. 0) THEN
               WRITE(*,'(1X,A,''[17D Ring_no    Year   Width   Monitor''
     &            )') CHAR(27)
               WRITE(*,'(1X,A,''[16C'',$)') CHAR(27)
               CALL BEEP
            ENDIF
            WRITE(*,'(1X,A,''[17D'',2I8,F8.3,F10.3)')
     &         CHAR(27), NYR, LYR, RM1(NYR), CUMV
            WRITE(*,'(1X,A,''[1;33mMeasure'',I9,A,''[1;32m'',$)')
     &         CHAR(27), LYR+1, CHAR(27)
         ENDIF
      IF (RWM .GE. 0.) GOTO 10
      RETURN
      END ! MESURE
*RTN SKIPRN: reset the stage on a ring boundary
*
* LYR. . .  date of the ring immediately before the ring boundary
* RESET. .  prompt the user to move the stage 
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE SKIPRN (LYR, RESET)
*
      IMPLICIT CHARACTER(Q)
*
      COMMON /CMINFO/ IUC, CUML, QCOM
      CHARACTER Q16*16
*## Diag      CHARACTER QDBUG*16
      LOGICAL RESET
*
      IF (RESET) THEN 
         WRITE(*,
     &        '('' Now move stage, set at start of next ring, press '',
     &        ''trigger'')')
*## Diag         QDBUG = 'Reset stage'
      ELSE
         WRITE(*,'('' Now set at start of next ring, press trigger'')')
*## Diag         QDBUG = 'Reset, continue'
      ENDIF
*     READ(IUC,'(A/)',ERR=997,END=997) Q16
      CALL GETCOM(QCOM, Q16)
      READ(Q16,'(1X,F10.3)') CUML
*## Diag      CALL COMLOG(Q16, QDBUG)
      WRITE(*,'('' Continue: now measure year'',I6)') LYR + 1
      RETURN
  997 CALL SALE('Error reading COM port')
      END ! SKIPRN
*RTN MENU1: Display the initial setup menu
*
* QX. . . . 'N' = display disclaimer menu option, ' ' = don't display
* QQNA. . . 'N' = new file, 'A' = append to existing file
* QQ32. . . '3' = .001 mm precision, '2' = .01 mm precision
* QCOM. . . MS-DOS COM device number ('1' = COM1:, '2' = COM2: &c.)
* QRS . . . ' ' = user has finished using the setup menu
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE MENU1 (QX, QQNA, QQ32, QCOM, QRS)
*
      IMPLICIT CHARACTER(Q)
*
   10 CALL BP(33, 43, ' ')
      WRITE(*,'(/16X,''P R O G R A M     M E D I R (HACKED)''//16X,
     &      ''S e t u p   m e n u'',T67,''Version 1.15 H'')')
      CALL BP(37,43,'N')
      WRITE(*,'(16X,''SET  (ALT)  Current setting''/
     &        16X,''---   ---   ---------------'')')
      IF (QX .EQ. 'N') THEN
         WRITE(*,
     &       '(17X,''Q or  ?    READ THIS BEFORE USING THE PROGRAM'')')
         QX=' '
      ENDIF
      IF (QQNA .EQ. 'A') THEN
         WRITE(*,
     &         '(17X,''A    (N)   Add to EXISTING measurement file'')')
      ELSE
         WRITE(*,'(17X,''N    (A)   Open a NEW measurement file'')')
      ENDIF
      IF (QQ32 .EQ. '2') THEN
         WRITE(*,'(17X,''2    (3)   Measurement precision .01 mm'')')
      ELSE
         WRITE(*,'(17X,''3    (2)   Measurement precision .001 mm'')')
      ENDIF
      WRITE(*,'(17X,A,''    (C)   COM port (1, 2, 3, 4)'')')QCOM
      WRITE(*,'(22X,''<CR>  Begin measurement''/
     &23X,''/    To quit at any time type a slash''//8X,
     &''Press the character listed under Alternate (ALT) to switch'',
     &'' options''/14X,''or <CR> (ENTER) to begin measurement'')')
      CALL BP(33, 43, 'N')
      CALL GETA('^		Selection', QRS)
      IF (INDEX('NA', QRS) .GT. 0) THEN
         QQNA = QRS
      ELSEIF (INDEX('32', QRS) .GT. 0) THEN
         QQ32 = QRS
      ENDIF
      IF (QRS .EQ. 'C') THEN
         CALL GETA('^COM port to use (1, 2, 3 or 4)', QCOM)
      ENDIF
      IF(INDEX('Q?', QRS) .GT. 0) THEN
         CALL DISCLM
      ENDIF
      RETURN
      END ! MENU1
*RTN DISCLM: Show the legal disclaimer message
*
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE DISCLM
*
      IMPLICIT CHARACTER(Q)
*
      CALL BP(33, 40, 'B')
      WRITE(*,'(1X,78(''_'')/'' )):) )) ) ) )) ) ) ).) ))) ) ) ) ))'',
     &'' ).) ) ) ) )) )) ) ).) )) ) )) ) ) )).)) )))''/1X,78(''-'')//
     &22X,''PROGRAM MEDIR -- DISCLAIMER'')')
      WRITE(*,'(/
     &'' The following disclaimer applies to all program code and '',
     &''any programs or'')')
      WRITE(*,'(
     &'' other software distributed directly or by any other means.''
     &)')
      WRITE(*,'(/
     &'' All software has received only limited testing and neither '',
     &''the authors,'')')
      WRITE(*,'(
     &'' the Laboratory of Tree-Ring Research, nor the University '',
     &''of Arizona can'')')
      WRITE(*,'(
     &''accept responsibility for its compatibility with other '',
     &''computer systems or'')')
      WRITE(*,'(
     &'' user needs.  The user must judge its efficacy for the '',
     &''intended use.'')')
      WRITE(*,'(/
     &'' Although every effort is made to ensure that the software '',
     &''functions'')')
      WRITE(*,'(
     &'' properly, no guarantee is made to this effect and we '',
     &''cannot be responsible'')')
      WRITE(*,'(
     &'' for any problems with it, including adaptation of the '',
     &''software to any'')')
      WRITE(*,'(
     &'' particular computer system.'')')
      WRITE(*,'(/
     &'' The software is made available free of charge.  Any '',
     &''payment accepted'')')
      WRITE(*,'(
     &'' is for actual costs of diskettes, copying, printing '',
     &''and/or postage.'')')
      CALL GETA('^Press key to return to menu', QK)
      CALL BP(33, 43, 'B')
      RETURN
      END ! DISCLM
*RTN DOFILE: Prompt for filename, open the measurement output file
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE DOFILE
*
      IMPLICIT CHARACTER(Q)
      COMMON /FLINFO/ IUR, IUB, Q20, QID, QQNA, QQ32, QCM, QRM
      CHARACTER QID*8, Q8*8, Q20*20
*
      CALL BP(35, 40, ' ')
      IF (QQNA .EQ. 'N') THEN
*        Open new file....
         WRITE(*,'('' File names may have up to 8 characters, '',
     &         ''no punctuation; `.RWL` will be added.'')')
         CALL GETA('|Name of new measurement file', Q8)
         LL = LARGO(Q8)
         Q20 = Q8(1:LL)//'.RWL'
         CALL OPENFI(IUR, Q20, 'N')
         QCM = 'N'
      ELSE
*        Open existing file....
         CALL GETA('|Name of file to which to add data', Q20)
         CALL OPENFI(IUR, Q20, 'A')
         CALL GETA(
     &     '^NEW series or CONTINUE partially measured series  <N>/C',
     &     QCM)
      ENDIF
      RETURN
      END ! DOFILE
*RTN PRPFIL: Prepare a file (either new or existing) for new output
*
* OK. . . . the file is new, or it's OK to modify an existing file
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE PRPFIL (OK)
*
      PARAMETER (MXD = 2048)
      IMPLICIT CHARACTER(Q)
      COMMON /RARR/ RM1(MXD), RM2(MXD)
      COMMON /FLINFO/ IUR, IUB, Q20, QID, QQNA, QQ32, QCM, QRM
      COMMON /DATES/ NYR, JYR, LYR, LYRM
      CHARACTER QID*8, Q20*20
      LOGICAL OK
*
      DO J = 1, MXD
         RM1(J) = 0.
         RM2(J) = 0.
      ENDDO
      QRM = ' '
      IF (QCM .NE. 'C') THEN
*        New series; get ident and first year....
   10    CONTINUE
            NYR = 0
            CALL GETA('|Enter series ID', QID)
            CALL GETI('Date of first year to measure', JYR)
            LYR = JYR + NYR - 1
            CALL GETA('^Are ID and year OK?  <Y>/N', QK)
         IF (QK .EQ. 'N') GOTO 10
         OK = .TRUE.
      ELSE
*        Get series from existing file....
         LL = MIN0(INDEX(Q20,'.') - 1, LARGO(Q20))
         WRITE(*,'('' Copying original file to backup file '',A,
     &         ''.BAK'')') Q20(1:LL)
         CALL OPENFI(IUB, Q20(1:LL)//'.BAK', 'N')
         CALL COPY(IUR, IUB)
         CALL OPENFI(IUR, Q20, 'U')
         NYR = 0
         CALL LISTTS(QID, JYR, LYR, NYR, IUB, 0, 0)
         CALL BP(36, 40, ' ')
         CALL GETI('Sequence number of series to continue measuring',
     &             NSER)
         WRITE(*,'('' Please wait while file is prepared:''/)')
         CALL LISTTS(QID, JYR, LYR, NYR, IUB, IUR, NSER)
         CLOSE(IUR)
         CALL OPENFI(IUR, Q20, 'A')
         CALL BP(33, 40, ' ')
         CALL VIEWER(QID, JYR, LYR, RM1)
         CALL BP(32, 40, ' ')
         WRITE(*,'('' Start measuring ring'',I6)') LYR + 1
         CALL GETA('^OK?  <Y>/N', QK)
         OK = (QK .NE. 'N')
      ENDIF
      RETURN
      END ! PRPFIL
*RTN NXTRNG: Prompt message for next ring
*
* NRNG . . . number of ring to measure
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE NXTRNG (NRNG)
*
      CALL BP(32, 40, ' ')
      WRITE(*,'('' To correct a ring measurement in progress, '',
     &''set monitor display''/'' value exactly equal to last monitor'',
     &'' value on the screen, place sample at''/'' start of ring, '',
     &''and remeasure.''//'' To exit measuring, set monitor display '',
     &''to a value less than the''/'' last monitor value on the '',
     &''screen and press button for INTERRUPT menu.''//
     &'' Now reset monitor to zero and measure ring'',I5/)') NRNG
      RETURN
      END ! NXTRNG
*RTN INMENU: Interrupted meausurement menu
*
* NOSLCT. . not yet done with making menu selections
* MORE. . . more of the current series to measure
* DONE. . . no more series to measure
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE INMENU (NOSLCT, MORE, DONE)
*
      IMPLICIT CHARACTER(Q)
      PARAMETER (MXD = 2048)
      COMMON /RARR/ RM1(MXD), RM2(MXD)
      COMMON /FLINFO/ IUR, IUB, Q20, QID, QQNA, QQ32, QCM, QRM
      COMMON /CMINFO/ IUC, CUML, QCOM
      COMMON /DATES/ NYR, JYR, LYR, LYRM
      CHARACTER QID*8, Q20*20
      LOGICAL DONE, MORE, NOSLCT
*
      DONE = .FALSE.
      MORE = .TRUE.
      CALL BP(36, 40, ' ')
      WRITE(*,'(''  I N T E R R U P T    M E N U''//
     &''  I   Insert value    R   Remeasure''/
     &''  X   Quit without saving''/
     &''  M   Move dating     C   Continue measuring''/
     &''  V   View data       S   Save measurements, go to SETUP menu''
     &/
     &''  D   Delete          Z   Reset stage to continue measuring'')'
     &)
      CALL GETA('^Enter selection', QINT)
      IF (QINT.EQ.'S') THEN
         CALL SAVMES (DONE)
         MORE   = .FALSE.
         NOSLCT = .FALSE. 
      ELSEIF (QINT .EQ. 'Z') THEN
         CALL SKIPRN (LYR, .TRUE.)
         NOSLCT = .FALSE. 
      ELSEIF (QINT .EQ. 'C') THEN
         CALL SKIPRN (LYR, .FALSE.)
         NOSLCT = .FALSE. 
      ELSEIF (QINT .EQ. 'R') THEN
         CALL VIEWER(QID, JYR, LYR, RM1)
         LYRM = LYR
         CALL GETI('Remeasure rings starting with what year', LYR)
         WRITE(*,'('' You may either:''/
     &''   (Y) remeasure to the end of the series, or''/
     &''   (N) remeasure a part, leaving the latter values intact.'')')
         CALL GETA('Will you remeasure to the end?  <Y>/N', QRM)
         NYR = LYR - JYR
         LYR = LYR - 1
         CALL SKIPRN (LYR, .FALSE.)
         NOSLCT = .FALSE. 
      ELSEIF (QINT .EQ. 'X') THEN
         CALL GETA('^Quit program without saving?  Y/<N>', QK)
         IF (QK .EQ. 'Y') CALL SALE('Quit')
      ELSEIF (QINT .EQ. 'I') THEN
         CALL INSMES
         NOSLCT = .TRUE. 
      ELSEIF (QINT .EQ. 'V') THEN
         CALL BP(35, 40, ' ')
         CALL VIEWER(QID, JYR, LYR, RM1)
         CALL GETA('^Press key for INTERRUPT menu', QK)
         NOSLCT = .TRUE. 
      ELSEIF (QINT .EQ. 'D') THEN
         CALL DELMES(QID)
         WRITE(*,'('' Series '',A,3I6,'' years'')') QID, JYR, LYR, NYR
         NOSLCT = .TRUE. 
      ELSEIF (QINT .EQ. 'M') THEN
         CALL GETA('^Enter direction to shift series:  '//
     &             'F: Forward  B: Back in time', QDD)
         CALL GETI('Enter number of years to shift', IDNUM)
         IF (QDD .EQ. 'F') THEN
            JYR = JYR + IDNUM
            LYR = LYR + IDNUM
         ELSEIF (QDD .EQ. 'B') THEN
            JYR=JYR-IDNUM
            LYR=LYR-IDNUM
         ENDIF
         NOSLCT = .TRUE. 
      ELSE
         WRITE(*,'(56X,''Unknown command!'',A)') CHAR(7)
         NOSLCT = .TRUE. 
      ENDIF
      RETURN
      END ! INMENU
*RTN SAVMES: Save measurements to a file
*
* DONE. . . no more series to measure
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE SAVMES (DONE)
*
      IMPLICIT CHARACTER(Q)
      PARAMETER (MXD = 2048)
      COMMON /RARR/ RM1(MXD), RM2(MXD)
      COMMON /FLINFO/ IUR, IUB, Q20, QID, QQNA, QQ32, QCM, QRM
      COMMON /DATES/ NYR, JYR, LYR, LYRM
      CHARACTER QID*8, Q20*20
      LOGICAL DONE
*
      CALL VIEWER(QID, JYR, LYR, RM1)
      CALL GETA('^Save the current measurements?  <Y>/N', QK)
      IF (QK .NE. 'N') THEN
         IF (QRM .EQ. 'N') THEN
*           Part remeasured....
            LYR = LYRM
            NYR = LYR - JYR + 1
         ENDIF
         CALL TRW(QID, NYR, RM1, JYR, IUR, Q20, QQ32)
         WRITE(*,'('' Measurement series '',A,'' saved in file'')') QID
         QCM = 'N'
         CALL GETA('^Will you measure another series?  <Y>/N', QK)
         DONE = (QK .EQ. 'N')
      ENDIF
      RETURN
      END ! SAVMES
*RTN INSMES: Insert measurement values from the keyboard
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE INSMES
*
      PARAMETER (MXD = 2048)
      IMPLICIT CHARACTER(Q)
      COMMON /RARR/ RM1(MXD), RM2(MXD)
      COMMON /DATES/ NYR, JYR, LYR, LYRM
*
      CALL GETI('Year before which to insert value(s)', INYR)
      CALL GETA('^Direction to shift series:  '//
     &          'F: Forward  <B>: Back in time', QDD)
      WRITE(*,'(40X,''(Give negative value to quit inserting)'')')
   10 CONTINUE
       CALL GETR('Enter value to insert', RWIN)
       IF (RWIN .LT. 0.) GOTO 20
         ISI = INYR - JYR + 1
         DO J = NYR + 1, ISI, -1
            RM1(J) = RM1(J-1)
         ENDDO
         RM1(ISI) = RWIN
         NYR = NYR + 1
         IF (QDD .EQ. 'F') THEN
            LYR = LYR + 1
            INYR = INYR + 1
         ELSE
            JYR = JYR - 1
         ENDIF
         GOTO 10
   20 CONTINUE
      RETURN
      END ! INSMES
*RTN DELMES: Delete measurements
*
* QID . . .  ID for measurement series
*
* Copyright (C) NOV 1991 by Paul J Krusic, Tree Ring Laboratory,
*    Lamont-Doherty Earth Observatory, Palisades, New York, USA
* Copyright (C) Richard L Holmes, Tucson, Arizona, USA
* Modified 29-Feb-1996 MARM
*
      SUBROUTINE DELMES (QID)
*
      PARAMETER (MXD = 2048)
      IMPLICIT CHARACTER(Q)
      COMMON /RARR/ RM1(MXD), RM2(MXD)
      COMMON /DATES/ NYR, JYR, LYR, LYRM
      CHARACTER QID*8, QPRMPT*64
      DATA QPRMPT
     &   /'^Direction to shift series:  F: Forward  <B>: Back in time'/
*
   10 CONTINUE
         WRITE(*,'(/'' Series '',A,3I6,'' years'')') QID, JYR, LYR, NYR
         CALL GETI('First year to delete', IDYR1)
         IF (IDYR1 .LT. JYR .OR. IDYR1 .GT. LYR) THEN
            QK = 'Q'
         ELSE
            CALL GETI('Last  year to delete', IDYR2)
            CALL GETA(QPRMPT, QDD)
            IDNUM = IDYR2 - IDYR1 + 1
            WRITE(*,
     &            '('' Deleting'',I5,'' measurements'',I6,'' to'',I5)')
     &            IDNUM, IDYR1, IDYR2
            CALL GETA('^OK?  <Y>/N', QK)
         ENDIF
      IF (QK .EQ. 'N') GOTO 10
      IF (QK .EQ. 'Y') THEN
         ISI = IDYR1 - JYR + 1
         DO J = ISI, NYR-IDNUM
            RM1(J) = RM1(J+IDNUM)
         ENDDO
         NYR = NYR - IDNUM
         DO J = NYR+1, MXD
            RM1(J) = 0.
         ENDDO
         IF (QDD .EQ. 'F') THEN
            JYR = JYR + IDNUM
         ELSE
            LYR = LYR - IDNUM
         ENDIF
      ENDIF
      RETURN
      END ! DELMES
*RTN WRLN: Character string written to scratch file
*
* VAX/VMS Fortran and several other compilers can read character strings
* in free format, but Microsoft Fortran for PC is not; hence this routine.
*
* Programmed copyright (C) SEP 1993 by
* Richard L Holmes, Tucson, Arizona, USA
* Modified copyright (C) 24 JAN 1995
*
      SUBROUTINE WRLN(LIN,IO)
      CHARACTER LIN*(*)
      SAVE
      DATA IOS/0/
*
      IF(IOS .EQ. 0)THEN
      IOS=63
      OPEN(IOS,RECL=8192,STATUS='SCRATCH')
      ENDIF
*
      IO=IOS
      LL=LARGO(LIN)
      REWIND(IO,ERR=1)
    1 WRITE(IO,'(A)')LIN(1:LL)
      REWIND(IO,ERR=2)
    2 END ! WRLN
*RTN LARGO: Position of last non-blank character in string
*
* Programmed copyright (C) FEB 1991 by
* Richard L Holmes, Tucson, Arizona, USA
* Modified copyright (C) 01 DEC 1992
*
      FUNCTION LARGO(Q)
      CHARACTER Q*(*)
      LL=LEN(Q)
      DO J=LL,1,-1
      K=ICHAR(Q(J:J))
      IF(K .NE. 32 .AND. K .NE. 0)THEN
      LARGO=J
      RETURN
      ENDIF
      ENDDO ! J loop
      LARGO=1
      END ! LARGO
*RTN BLANC: Blanks character string
*
* Programmed copyright (C) DEC 1986 by
* Richard L Holmes, Tucson, Arizona, USA
* Modified copyright (C) 04 AUG 1990
*
      SUBROUTINE BLANC(L)
      CHARACTER L*(*)
      LL=LEN(L)
      DO I=1,LL
      L(I:I)=' '
      ENDDO
      END ! BLANC
*RTN GETA: For PC; converts input character string to CAPITALS
*
* Programmed copyright (C) NOV 1990 by
* Richard L Holmes, Tucson, Arizona, USA
* Modified copyright (C) 26 JAN 1995
*
* Prompts for character string and returns it in UPPER CASE
* If first character is '|' a line is skipped before prompt.
* If first character is '^' a line is skipped before prompt, and
* variable is read like GET in BASIC.
*
      SUBROUTINE GETA(A,B)
      IMPLICIT CHARACTER(Q)
*
CC+     extern int getch(void); C-
CC+     char tempch; C-
*
      CHARACTER QP*4,A*(*),B*(*)
      DATA QP/' => '/
      LL=LARGO(A)
*
      IF(A(1:1) .EQ. '|' .OR. A(1:1) .EQ. '^')THEN
      WRITE(*,'(/1X,2A,$)')A(2:LL),QP
      ELSE
      WRITE(*,'(1X,2A,$)')A(1:LL),QP
      ENDIF
*
      IF(A(1:1) .EQ. '^')THEN
CC+     k = getch(); C-
CC+     tempch = k; C-
CC+     s_copy(b, &tempch, b_len, 1L); C-
*F    K=ICHAR(B)
      IF((K .LT. 32 .OR. K .GT. 126) .AND. K .NE. 9)B=' '
      WRITE(*,'('' '')')
      ELSE
      READ(*,'(A)')B
      ENDIF
*
      IF(B(1:1) .EQ. '/')CALL SALE(' ')
      CALL CAPS(B)
      END ! GETA
*RTN GETI: Input INTEGER
*
* Programmed copyright (C) MAR 1987 by
* Richard L Holmes, Holzbiologie - BFH, Universitaet Hamburg - Germany
* Modified copyright (C) 13 SEP 1993
*
      SUBROUTINE GETI(LIN,I)
      IMPLICIT CHARACTER(Q)
      CHARACTER CHAR,LNE*10,LIN*(*),C2*3
      SAVE
      DATA C2/'[1A'/
*
* Integer
    1 CALL GETA(LIN,LNE)
      LL=LARGO(LNE)
*
* Read character string
*`P+      CALL WRLN(LNE,IOS)
*`P+      READ(IOS,*,ERR=98,END=98)I
*`P-
      READ(LNE,*,ERR=98,END=98)I
      RETURN
*
* Set null string to zero or error message
   98 IF(LL .LE. 1 .AND. LNE(1:1) .EQ. ' ')THEN
      I=0
      RETURN
      ENDIF
      WRITE(*,'(1X,2A,70('' ''),T73,''INTEGER!'',3A)')
     &CHAR(27),C2,CHAR(27),C2,CHAR(7)
      GOTO 1
      END ! GETI
*RTN GETR: Input REAL number
*
* Programmed copyright (C) MAR 1987 by
* Richard L Holmes, Holzbiologie - BFH, Universitaet Hamburg - Germany
* Modified copyright (C) 13 SEP 1993
*
      SUBROUTINE GETR(LIN,R)
      IMPLICIT CHARACTER(Q)
      CHARACTER CHAR,LNE*10,LIN*(*),C2*3
      SAVE
      DATA C2/'[1A'/
*
    1 CALL GETA(LIN,LNE)
      LL=LARGO(LNE)
*
* Read character string
*`P+      CALL WRLN(LNE,IOS)
*`P+      READ(IOS,*,ERR=98,END=98)R
*`P-
      READ(LNE,*,ERR=98,END=98)R
      RETURN
*
* Set null string to zero or error message
   98 IF(LL .LE. 1 .AND. LNE(1:1) .EQ. ' ')THEN
      R=0.
      RETURN
      ENDIF
      WRITE(*,'(1X,2A,70('' ''),T74,''NUMBER!'',3A)')
     &CHAR(27),C2,CHAR(27),C2,CHAR(7)
      GOTO 1
      END ! GETR
*RTN CAPS: Converts character string to CAPITALS
*
* Programmed copyright (C) NOV 1986 by
* Richard L Holmes, Tucson, Arizona, USA
* Modified copyright (C) 06 MAR 1991
*
      SUBROUTINE CAPS(L)
      CHARACTER CHAR,L*(*)
      DATA LA,LZ,LD/97,122,-32/
      LL=LEN(L)
      DO I=1,LL
      K=ICHAR(L(I:I))
      IF(K .GE. LA .AND. K .LE. LZ)L(I:I)=CHAR(K+LD)
      ENDDO
      END ! CAPS
*RTN TRW: Read/write measurements/indices
*
* Programmed copyright (C) JUN 1984 by
* Richard L Holmes, University of Arizona, Tucson, Arizona, USA
* Modified copyright (C) 07 FEB 1995
*
* Read or write tree-ring measurements in standard formats of the
* International Tree-Ring Data Bank (ITRDB).  Measurements may be read or
* written in the ITRDB format (precision .01 mm, end flag = 999) or the
* TRL-LDEO format (precision .001 mm, end flag = -9999)
*
*   CALL TRW(QID,N,Y,JYR,IO,Q20,QF)
*
* QID: Series identification up to 8 characters
* N:   Number of data values in series; returned as zero at end-of-file
* Y:   Array of index or measurement values.
* JYR: Starting year of series
* IO:  Unit for reading or writing data
* Q20: File name to which to append; if "!" then file not closed and reopened
* QF:  Character to indicate action desired:
*
* Read measurements from file:	QF = 'R'
* Write measurements on file:
*	Precision .001 mm	QF = '3'
*	Precision .01 mm	QF = '2'
*
      SUBROUTINE TRW(QID,N,Y,JYR,IO,Q20,QF)
      IMPLICIT CHARACTER(Q)
      CHARACTER QID*(*),QIDA*8,Q20*20,LIN*80
      INTEGER IYD(10)
      REAL Y(1),YD(10)
*     DATA QT/' '/
*
* Find what action to do
      IF(QF .NE. 'R')THEN
*
* Precision .001
      IF(QF .EQ. '3')THEN
      CONS=1000.
*
* Precision .01
      ELSE
      CONS=100.
      ENDIF
      GOTO 5
      ENDIF
      N=0
      ISW=0
      IER=0
*
* Read line from file
      GOTO 1
   91 IER=IER+1
      IF(IER .GT. 25)STOP'>> Sbr TRW:  Text over 25 lines'
    1 READ(IO,'(A)',ERR=99,END=99)LIN
      IF(LARGO(LIN) .LE. 8)GOTO 1
*
* Read measurements
      IF(QF .EQ. 'R')THEN
      IF(LIN(8:8) .EQ. '-')THEN
      READ(LIN,'(A,I5,10F6.2)',ERR=91,END=99)QIDA(1:7),JYR1,YD
      QIDA(8:8)=' '
      ELSE
      READ(LIN,'(A,I4,10F6.2)',ERR=91,END=99)QIDA,JYR1,YD
      ENDIF
      ENDIF
      ISW=ISW+1
      L=10
      IF(ISW .EQ. 1)THEN
      QID=QIDA
      JYR=JYR1
      IF(JYR .GE. 0)THEN
      L=10-MOD(JYR,10)
      ELSE
      L=ABS(MOD(JYR,10))
      IF(L .EQ. 0)L=10
      ENDIF
      ENDIF
      IF(QF .EQ. 'R')GOTO 3
      L=11-L
      DO 10 I=L,10
      IF(YD(I) .LT. 9.99)THEN
      N=N+1
      Y(N)=YD(I)
      ELSE
      GOTO 999
      ENDIF
   10 CONTINUE
      GOTO 1
   99 N=0
      GOTO 999
*
* Ring measurement
    3 DO I=1,L
*
* End flag reached
      IF(ABS(YD(I)-9.99).LT. .0001 .OR. ABS(YD(I)+99.99).LT. .0001)THEN
*
* If end flag is -9999, precision is .001 mm
      IF(YD(I) .LT. -99.98)THEN
      DO II=1,N
      Y(II)=.1*Y(II)
      ENDDO
      ENDIF
      GOTO 999
      ENDIF
      N=N+1
      Y(N)=YD(I)
      ENDDO ! I loop
*
      GOTO 1
    5 IF(N .LE. 0)GOTO 999
      IER=0
      J=0
      KYR=JYR
    4 IF(JYR .GE. 0)THEN
      L=10-MOD(JYR,10)
      ELSE
      L=ABS(MOD(JYR,10))
      IF(L .EQ. 0)L=10
      ENDIF
   42 DO I=1,L
      J=J+1
      IF(J .GT. N)THEN
*
* Precision .001
      IF(QF .EQ. '3')THEN
      IYD(I)=-9999
*
* Precision .01
      ELSE
      IYD(I)=999
      ENDIF
*
      L=I
      J=-999
      GOTO 51
      ELSE
      IYD(I)=NINT(Y(J)*CONS)
      IF(IYD(I) .EQ. 999)IYD(I)=998
      ENDIF
      ENDDO
   51 IF(KYR .LT. -999)THEN
      WRITE(IO,'(A,I5,10I6)')QID(1:7),KYR,(IYD(K),K=1,L)
      ELSE
      WRITE(IO,'(A,I4,10I6)')QID(1:8),KYR,(IYD(K),K=1,L)
      ENDIF
      IF(J .LT. 0)GOTO 999
      KYR=KYR+L
      L=10
      GOTO 42
  999 IF(QF .NE. 'R' .AND. Q20(1:1) .NE. '!')THEN
      CLOSE(IO)
      CALL OPENFI(IO,Q20,'A')
      ENDIF
      END ! TRW
*RTN OPENFI: Open file
*
* Programmed copyright (C) JAN 1995 by
* Richard L Holmes, University of Arizona, Tucson, Arizona, USA
* Modified copyright (C) 06 FEB 1995
*
* N: New
* O: Old
* A: Append
* U: Unknown
* S: Scratch
* D: Direct
*
      SUBROUTINE OPENFI(IO,QFL,QT)
      IMPLICIT CHARACTER(Q)
      CHARACTER CHAR,QFL*(*)
*
    1 CALL QFILL(QFL)
*
* New file
      IF(QT .EQ. 'N')THEN
*?      OPEN(IO,FILE=QFL,STATUS='NEW',RECL=2048,ERR=2)
      OPEN(IO,FILE=QFL,STATUS='NEW',ERR=2)
      RETURN
*
* Ask if file should be overwritten
    2 WRITE(*,'('' Cannot open new file '',A/
     &'' Overwrite existing file or give new file name'',A)')
     &QFL,CHAR(7)
      CALL GETA('Overwrite existing file?  <Y>/N',QO)
*
      IF(QO .EQ. 'N')THEN
      CALL GETA('  ... Name of NEW file to create',QFL)
      CALL QFILL(QFL)
*?      OPEN(IO,FILE=QFL,STATUS='NEW',RECL=2048,ERR=2)
      OPEN(IO,FILE=QFL,STATUS='NEW',ERR=2)
      ELSE
*?      OPEN(IO,FILE=QFL,STATUS='UNKNOWN',RECL=2048,ERR=2)
      OPEN(IO,FILE=QFL,STATUS='UNKNOWN',ERR=2)
      ENDIF
*
      ELSEIF(QT .EQ. 'O')THEN
      OPEN(IO,FILE=QFL,STATUS='OLD',ERR=98)
      ELSEIF(QT .EQ. 'A')THEN
      OPEN(IO,FILE=QFL,STATUS='OLD',ACCESS='APPEND',ERR=98)
*##      OPEN(IO,FILE=QFL,STATUS='OLD',ACCESS='APPEND',ERR=7)
*##      RETURN
*##    7 OPEN(IO,FILE=QFL,STATUS='NEW',ERR=98)
      ELSEIF(QT .EQ. 'U')THEN
      OPEN(IO,FILE=QFL,STATUS='UNKNOWN',ERR=98)
      ELSEIF(QT .EQ. 'S')THEN
*?      OPEN(IO,STATUS='SCRATCH',RECL=2048,ERR=97)
      OPEN(IO,STATUS='SCRATCH',ERR=97)
      ELSEIF(QT .EQ. 'D')THEN
      OPEN(IO,STATUS='SCRATCH',ACCESS='DIRECT',RECL=4096,ERR=97)
      ENDIF
      RETURN
   98 WRITE(*,'('' Error opening file '',2A)')QFL,CHAR(7)
      CALL GETA('  ... Name of EXISTING file to open',QFL)
      GOTO 1
   97 STOP'Error opening scratch file'
      END ! OPENFI
*RTN QFILL: Omit spaces in character string
*
* Programmed copyright (C) DEC 1993 by
* Richard L Holmes, University of Arizona, Tucson, Arizona, USA
* Modified copyright (C) 06 FEB 1995
*
* QL: Character string to fill to left
*
      SUBROUTINE QFILL(QL)
      CHARACTER QZ*32,QL*(*)
*
      LL=LARGO(QL)
      CALL BLANC(QZ)
      NS=0
      DO I=1,LL
      IF(ICHAR(QL(I:I)) .NE. 32 .AND. ICHAR(QL(I:I)) .NE. 0)THEN
      NS=NS+1
      QZ(NS:NS)=QL(I:I)
      ENDIF
      ENDDO ! I loop
      QL=QZ
      END ! QFILL
*RTN COPY: Copies contents of file IR onto file IW
*
* Programmed copyright (C) SEP 1982 by
* Richard L Holmes, University of Arizona, Tucson, Arizona, USA
* Modified copyright (C) 06 FEB 1995
*
      SUBROUTINE COPY(IR,IW)
      CHARACTER LIN*84
*
      IF(IR .EQ. IW)RETURN
      REWIND(IR)
    1 READ(IR,'(A)',ERR=99,END=99)LIN
      J=LARGO(LIN)
      WRITE(IW,'(A)')LIN(1:J)
      GOTO 1
   99 CLOSE(IR)
      END ! COPY
*RTN VIEWER: Time series viewed on screen
*
* Programmed copyright (C) by
* Richard L Holmes, Tree Ring Laboratory
* Lamont-Doherty Earth Observatory, Palisades, New York  10964  USA
* Modified copyright (C) 07 FEB 1995
*
* QID:      Series identification
* JYR, LYR: First & last years of series
* Y:        Array of values
*
      SUBROUTINE VIEWER(QID,JYR,LYR,Y)
      IMPLICIT CHARACTER(Q)
      CHARACTER QID*8,QZ(10)*7
      REAL Y(JYR:LYR)
*
* Print heading
      CALL BP(33,40,' ')
      WRITE(*,'(/1X,A,I6,9I7)')QID,(K,K=0,9)
      IF(JYR .LT. -10)WRITE(*,'(13X,''-0'',9I7)')(K,K=-9,-1)
*
      J=JYR-1
      JY=JYR
      NL=0
    2 DO I=1,10
      CALL BLANC(QZ(I))
      ENDDO
    1 J=J+1
*
* Find place for data
      IF(J .GE. 0)THEN
      M=MOD(J,10)+1
      ELSE
      M=11-MOD(IABS(J),10)
      IF(M .EQ. 11)M=1
      ENDIF
*
      WRITE(QZ(M),'(I7)')NINT(Y(J)*1000.)
*
      IF(M .EQ. 10 .OR. J .EQ. LYR)THEN
      WRITE(*,'(I7,2X,10A)')JY,QZ
      IF(J .GE. LYR)RETURN
      JY=J+1
      NL=NL+1
      IF(MOD(NL,20).EQ.0)THEN
      CALL GETA('^Press key for more',Q)
      CALL BP(33,40,' ')
      WRITE(*,'(1X,A,I6,9I7)')QID,(K,K=0,9)
      ENDIF
      GOTO 2
      ENDIF
      GOTO 1
      END ! VIEWER
*RTN LISTTS: List time series
*
* Programmed copyright (C) JAN 1995 by
* Richard L Holmes, University of Arizona, Tucson, Arizona, USA
* Modified copyright (C) 07 FEB 1995
*
      SUBROUTINE LISTTS(QIL,JYR,LYR,NYR,IU,IUN,NGET)
      PARAMETER(MXD=2048)
      IMPLICIT CHARACTER(Q)
      CHARACTER QIL*8,QID*8
      COMMON/RARR/RM1(MXD),RM2(MXD)
*
      REWIND(IU)
      NSER=0
    1 CALL TRW(QID,NY,RM2,JY,IU,'!','R')
      IF(NY .LE. 0)GOTO 2
      NSER=NSER+1
      LY=JY+NY-1
*
* List series if NGET is 0
      IF(NGET.LE.0)THEN
      IF(MOD(NSER,20).EQ.1.AND.NSER.GT.1)THEN
      CALL GETA('^Press key for more, `N` to quit list',Q)
      IF(Q .EQ. 'N')GOTO 2
      ENDIF
      WRITE(*,'(I6,2X,A,3I6)')NSER,QID,JY,LY,NY
      ENDIF
*
      IF(NSER.EQ.NGET)THEN
      JYR=JY
      LYR=LY
      NYR=NY
      QIL=QID
      DO I=1,NYR
      RM1(I)=RM2(I)
      ENDDO ! I loop
      ELSEIF(IUN.GT.0)THEN
      CALL TRW(QID,NY,RM2,JY,IUN,'!','3')
      WRITE(*,'(''+'',I5,2X,A)')NSER,QID
      ENDIF
*
      GOTO 1
*
    2 IF(NGET.LE.0)REWIND(IU)
      END ! LISTTS
*RTN COMLOG: Log of COM port output
*
* Programmed copyright (C) FEB 1995 by
* Richard L Holmes, University of Arizona, Tucson, Arizona, USA
* Modified copyright (C) 03 FEB 1995
*
      SUBROUTINE COMLOG(Q16,QMSG)
      CHARACTER Q16*16,Q,QMSG*(*)
      SAVE
      DATA Q/' '/
      CALL OPENFI(14,'COM.LOG','A')
      IF(Q .EQ. ' ')WRITE(14,'(''*** Start new COM.LOG file ***'')')
      Q='C'
      WRITE(14,'(2A)')Q16,QMSG
      CLOSE(14)
      END ! COMLOG
*RTN BP: Cambiar colores de pantalla; borrar pantalla
*
* Programmed copyright (C) SEP 1989 by
* Richard L Holmes, Lab. de Dendrocronologia, CRICYT - Mendoza - Argentina
* Modified copyright (C) 07 FEB 1995
*
      SUBROUTINE BP(KA,KB,Q)
      CHARACTER CHAR,Q
      SAVE
      DATA LB/43/
      WRITE(*,'(1X,A,''[0;1;'',I2,'';'',I2,''m'')')CHAR(27),KA,KB
      IF(Q.EQ.'B'.OR.(Q.NE.'N'.AND.LB.NE.40))
     &WRITE(*,'(/1X,A,''[2J'',A,''[H'')')(CHAR(27),M=1,2)
      LB=KB
      END ! BP
*RTN SALE: Exit program, setting screen to White on Blue
*
* Programmed copyright (C) JAN 1995 by
* Richard L Holmes, Tucson, Arizona, USA
* Modified copyright (C) 16 JAN 1996
*
      SUBROUTINE SALE(QLIN)
      CHARACTER QLIN*(*)
      CALL BP(37,44,' ')
      IF(QLIN(1:1) .NE. ' ')WRITE(*,'(/1X,A)')QLIN
      STOP'- = [  MEDIR  ] = -'
      END ! SALE
