/* medirh.f -- translated by f2c (version 19960225). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ #include "f2c.h" /* Common Block Declarations */ struct { real rm1[2048], rm2[2048]; } rarr_; #define rarr_1 rarr_ struct { integer iur, iub; char q20[20], qid[8], qqna[1], qq32[1], qcm[1], qrm[1]; } flinfo_; #define flinfo_1 flinfo_ struct { integer iuc; real cuml; char qcom[1]; } cminfo_; #define cminfo_1 cminfo_ struct { integer nyr, jyr, lyr, lyrm; } dates_; #define dates_1 dates_ /* Table of constant values */ static integer c__1 = 1; static integer c__33 = 33; static integer c__43 = 43; static integer c__37 = 37; static integer c__40 = 40; static integer c__35 = 35; static integer c__2 = 2; static integer c__0 = 0; static integer c__36 = 36; static integer c__32 = 32; static logical c_true = TRUE_; static logical c_false = FALSE_; static integer c__3 = 3; static integer c__4 = 4; static integer c__10 = 10; static integer c__14 = 14; static integer c__44 = 44; /* 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 */ /* Main program */ MAIN__(void) { /* System generated locals */ integer i__1; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int sale_(char *, ftnlen); static logical done, more; extern /* Subroutine */ int menu1_(char *, char *, char *, char *, char *, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); static logical ok; extern /* Subroutine */ int dofile_(void); static char qx[1]; extern /* Subroutine */ int setcom_(char *, ftnlen), inmenu_(logical *, logical *, logical *), prpfil_(logical *), mesure_(void); static logical noslct; extern /* Subroutine */ int nxtrng_(integer *); static char qrs[1]; /* Fortran I/O blocks */ static cilist io___7 = { 0, 6, 0, "(' Measurements in file ',A)", 0 }; cminfo_1.iuc = 10; flinfo_1.iur = 11; flinfo_1.iub = 12; *(unsigned char *)flinfo_1.qqna = 'N'; *(unsigned char *)flinfo_1.qq32 = '3'; *(unsigned char *)qx = 'N'; *(unsigned char *)cminfo_1.qcom = '2'; done = FALSE_; ok = FALSE_; L10: L20: if (ok) { goto L40; } L30: menu1_(qx, flinfo_1.qqna, flinfo_1.qq32, cminfo_1.qcom, qrs, 1L, 1L, 1L, 1L, 1L); if (*(unsigned char *)qrs != ' ') { goto L30; } dofile_(); prpfil_(&ok); goto L20; L40: i__1 = dates_1.lyr + 1; nxtrng_(&i__1); /* 1200 baud, No parity, 8 data, 2 stop bits, retry sending... */ setcom_(cminfo_1.qcom, 1L); /* Open COM port to read values.... */ /* CALL OPENFI(IUC, 'COM'//QCOM, 'O') */ cminfo_1.cuml = 0.f; L50: mesure_(); L60: inmenu_(&noslct, &more, &done); if (noslct) { goto L60; } if (more) { goto L50; } if (! done) { prpfil_(&ok); } if (! done) { goto L10; } s_wsfe(&io___7); do_fio(&c__1, flinfo_1.q20, 20L); e_wsfe(); sale_("Tree ))))))))))) Rings!", 23L); return 0; } /* MAIN__ */ /* 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 */ /* MEDIR */ /* Subroutine */ int mesure_(void) { /* System generated locals */ integer i__1; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void), s_rsfi(icilist *), e_rsfi(void); /* Local variables */ extern /* Subroutine */ int beep_(void); static real cumv; static char q16[16]; extern /* Subroutine */ int getcom_(char *, char *, ftnlen, ftnlen); static real rwm; /* Fortran I/O blocks */ static cilist io___8 = { 0, 6, 0, "(1X,A,'[16C',$)", 0 }; static icilist io___10 = { 0, q16, 0, "(1X,F10.3)", 16, 1 }; static cilist io___13 = { 0, 6, 0, "(1X,A,'[17D Ring_no Year Width " " Monitor' )", 0 }; static cilist io___14 = { 0, 6, 0, "(1X,A,'[16C',$)", 0 }; static cilist io___15 = { 0, 6, 0, "(1X,A,'[17D',2I8,F8.3,F10.3)", 0 }; static cilist io___16 = { 0, 6, 0, "(1X,A,'[1;33mMeasure',I9,A,'[1;32m'," "$)", 0 }; s_wsfe(&io___8); do_fio(&c__1, "\033", 1L); e_wsfe(); L10: /* READ(IUC,'(A/)') Q16 */ getcom_(cminfo_1.qcom, q16, 1L, 16L); s_rsfi(&io___10); do_fio(&c__1, (char *)&cumv, (ftnlen)sizeof(real)); e_rsfi(); /* ## Diag CALL COMLOG(Q16, 'Data') */ rwm = cumv - cminfo_1.cuml; if (rwm >= 0.f) { ++dates_1.nyr; ++dates_1.lyr; rarr_1.rm1[dates_1.nyr - 1] = rwm; cminfo_1.cuml = cumv; /* Beep on decade; note ring measurement.... */ if (dates_1.lyr % 10 == 0) { s_wsfe(&io___13); do_fio(&c__1, "\033", 1L); e_wsfe(); s_wsfe(&io___14); do_fio(&c__1, "\033", 1L); e_wsfe(); beep_(); } s_wsfe(&io___15); do_fio(&c__1, "\033", 1L); do_fio(&c__1, (char *)&dates_1.nyr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&dates_1.lyr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&rarr_1.rm1[dates_1.nyr - 1], (ftnlen)sizeof( real)); do_fio(&c__1, (char *)&cumv, (ftnlen)sizeof(real)); e_wsfe(); s_wsfe(&io___16); do_fio(&c__1, "\033", 1L); i__1 = dates_1.lyr + 1; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); do_fio(&c__1, "\033", 1L); e_wsfe(); } if (rwm >= 0.f) { goto L10; } return 0; } /* 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 */ /* MESURE */ /* Subroutine */ int skiprn_(integer *lyr, logical *reset) { /* System generated locals */ integer i__1; /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void), s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void); /* Local variables */ extern /* Subroutine */ int sale_(char *, ftnlen); static char q16[16]; extern /* Subroutine */ int getcom_(char *, char *, ftnlen, ftnlen); /* Fortran I/O blocks */ static cilist io___17 = { 0, 6, 0, "(' Now move stage, set at start of n" "ext ring, press ', 'trigger')", 0 }; static cilist io___18 = { 0, 6, 0, "(' Now set at start of next ring, pr" "ess trigger')", 0 }; static icilist io___20 = { 0, q16, 0, "(1X,F10.3)", 16, 1 }; static cilist io___21 = { 0, 6, 0, "(' Continue: now measure year',I6)", 0 }; /* ## Diag CHARACTER QDBUG*16 */ if (*reset) { s_wsfe(&io___17); e_wsfe(); /* ## Diag QDBUG = 'Reset stage' */ } else { s_wsfe(&io___18); e_wsfe(); /* ## Diag QDBUG = 'Reset, continue' */ } /* READ(IUC,'(A/)',ERR=997,END=997) Q16 */ getcom_(cminfo_1.qcom, q16, 1L, 16L); s_rsfi(&io___20); do_fio(&c__1, (char *)&cminfo_1.cuml, (ftnlen)sizeof(real)); e_rsfi(); /* ## Diag CALL COMLOG(Q16, QDBUG) */ s_wsfe(&io___21); i__1 = *lyr + 1; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfe(); return 0; /* L997: */ sale_("Error reading COM port", 22L); return 0; } /* 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 */ /* SKIPRN */ /* Subroutine */ int menu1_(char *qx, char *qqna, char *qq32, char *qcom, char *qrs, ftnlen qx_len, ftnlen qqna_len, ftnlen qq32_len, ftnlen qcom_len, ftnlen qrs_len) { /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen), bp_( integer *, integer *, char *, ftnlen), disclm_(void); /* Fortran I/O blocks */ static cilist io___22 = { 0, 6, 0, "(/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')", 0 }; static cilist io___23 = { 0, 6, 0, "(16X,'SET (ALT) Current setting'/ " " 16X,'--- --- ---------------')", 0 }; static cilist io___24 = { 0, 6, 0, "(17X,'Q or ? READ THIS BEFORE US" "ING THE PROGRAM')", 0 }; static cilist io___25 = { 0, 6, 0, "(17X,'A (N) Add to EXISTING mea" "surement file')", 0 }; static cilist io___26 = { 0, 6, 0, "(17X,'N (A) Open a NEW measurem" "ent file')", 0 }; static cilist io___27 = { 0, 6, 0, "(17X,'2 (3) Measurement precisi" "on .01 mm')", 0 }; static cilist io___28 = { 0, 6, 0, "(17X,'3 (2) Measurement precisi" "on .001 mm')", 0 }; static cilist io___29 = { 0, 6, 0, "(17X,A,' (C) COM port (1, 2, 3," " 4)')", 0 }; static cilist io___30 = { 0, 6, 0, "(22X,' Begin measurement'/ " " 23X,'/ To quit at any time type a slash'//" "8X, 'Press the character listed under Alternate (" "ALT) to switch', ' options'/14X,'or (ENTER) to begin meas" "urement')", 0 }; /* L10: */ bp_(&c__33, &c__43, " ", 1L); s_wsfe(&io___22); e_wsfe(); bp_(&c__37, &c__43, "N", 1L); s_wsfe(&io___23); e_wsfe(); if (*(unsigned char *)qx == 'N') { s_wsfe(&io___24); e_wsfe(); *(unsigned char *)qx = ' '; } if (*(unsigned char *)qqna == 'A') { s_wsfe(&io___25); e_wsfe(); } else { s_wsfe(&io___26); e_wsfe(); } if (*(unsigned char *)qq32 == '2') { s_wsfe(&io___27); e_wsfe(); } else { s_wsfe(&io___28); e_wsfe(); } s_wsfe(&io___29); do_fio(&c__1, qcom, 1L); e_wsfe(); s_wsfe(&io___30); e_wsfe(); bp_(&c__33, &c__43, "N", 1L); geta_("^\t\tSelection", qrs, 12L, 1L); if (i_indx("NA", qrs, 2L, 1L) > 0) { *(unsigned char *)qqna = *(unsigned char *)qrs; } else if (i_indx("32", qrs, 2L, 1L) > 0) { *(unsigned char *)qq32 = *(unsigned char *)qrs; } if (*(unsigned char *)qrs == 'C') { geta_("^COM port to use (1, 2, 3 or 4)", qcom, 31L, 1L); } if (i_indx("Q?", qrs, 2L, 1L) > 0) { disclm_(); } return 0; } /* menu1_ */ /* RTN DISCLM: Show the legal disclaimer message */ /* Copyright (C) Richard L Holmes, Tucson, Arizona, USA */ /* Modified 29-Feb-1996 MARM */ /* MENU1 */ /* Subroutine */ int disclm_(void) { /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen), bp_( integer *, integer *, char *, ftnlen); static char qk[1]; /* Fortran I/O blocks */ static cilist io___31 = { 0, 6, 0, "(1X,78('_')/' )):) )) ) ) )) ) ) ).)" " ))) ) ) ) ))', ' ).) ) ) ) )) )) ) ).) )) ) )) ) ) )).)) )))'/" "1X,78('-')// 22X,'PROGRAM MEDIR -- DISCLAIMER')", 0 }; static cilist io___32 = { 0, 6, 0, "(/ " " ' The following disclaimer applies to all p" "rogram code and ', 'any programs or')", 0 }; static cilist io___33 = { 0, 6, 0, "( " " ' other software distributed directly or by" " any other means.' )", 0 }; static cilist io___34 = { 0, 6, 0, "(/ " " ' All software has received only limited te" "sting and neither ', 'the authors,')", 0 }; static cilist io___35 = { 0, 6, 0, "( " " ' the Laboratory of Tree-Ring Research, nor" " the University ', 'of Arizona can')", 0 }; static cilist io___36 = { 0, 6, 0, "( " " 'accept responsibility for its compatibilit" "y with other ', 'computer systems or')", 0 }; static cilist io___37 = { 0, 6, 0, "( " " ' user needs. The user must judge its effi" "cacy for the ', 'intended use.')", 0 }; static cilist io___38 = { 0, 6, 0, "(/ " " ' Although every effort is made to ensure t" "hat the software ', 'functions')", 0 }; static cilist io___39 = { 0, 6, 0, "( " " ' properly, no guarantee is made to this ef" "fect and we ', 'cannot be responsible')", 0 }; static cilist io___40 = { 0, 6, 0, "( " " ' for any problems with it, including adapt" "ation of the ', 'software to any')", 0 }; static cilist io___41 = { 0, 6, 0, "( " " ' particular computer system.')", 0 }; static cilist io___42 = { 0, 6, 0, "(/ " " ' The software is made available free of ch" "arge. Any ', 'payment accepted')", 0 }; static cilist io___43 = { 0, 6, 0, "( " " ' is for actual costs of diskettes, copying" ", printing ', 'and/or postage.')", 0 }; bp_(&c__33, &c__40, "B", 1L); s_wsfe(&io___31); e_wsfe(); s_wsfe(&io___32); e_wsfe(); s_wsfe(&io___33); e_wsfe(); s_wsfe(&io___34); e_wsfe(); s_wsfe(&io___35); e_wsfe(); s_wsfe(&io___36); e_wsfe(); s_wsfe(&io___37); e_wsfe(); s_wsfe(&io___38); e_wsfe(); s_wsfe(&io___39); e_wsfe(); s_wsfe(&io___40); e_wsfe(); s_wsfe(&io___41); e_wsfe(); s_wsfe(&io___42); e_wsfe(); s_wsfe(&io___43); e_wsfe(); geta_("^Press key to return to menu", qk, 28L, 1L); bp_(&c__33, &c__43, "B", 1L); return 0; } /* 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 */ /* DISCLM */ /* Subroutine */ int dofile_(void) { /* System generated locals */ address a__1[2]; integer i__1[2]; /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void); /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen); extern integer largo_(char *, ftnlen); static char q8[8]; extern /* Subroutine */ int bp_(integer *, integer *, char *, ftnlen); static integer ll; extern /* Subroutine */ int openfi_(integer *, char *, char *, ftnlen, ftnlen); /* Fortran I/O blocks */ static cilist io___45 = { 0, 6, 0, "(' File names may have up to 8 chara" "cters, ', 'no punctuation; `.RWL` will be added.')" , 0 }; bp_(&c__35, &c__40, " ", 1L); if (*(unsigned char *)flinfo_1.qqna == 'N') { /* Open new file.... */ s_wsfe(&io___45); e_wsfe(); geta_("|Name of new measurement file", q8, 29L, 8L); ll = largo_(q8, 8L); /* Writing concatenation */ i__1[0] = ll, a__1[0] = q8; i__1[1] = 4, a__1[1] = ".RWL"; s_cat(flinfo_1.q20, a__1, i__1, &c__2, 20L); openfi_(&flinfo_1.iur, flinfo_1.q20, "N", 20L, 1L); *(unsigned char *)flinfo_1.qcm = 'N'; } else { /* Open existing file.... */ geta_("|Name of file to which to add data", flinfo_1.q20, 34L, 20L); openfi_(&flinfo_1.iur, flinfo_1.q20, "A", 20L, 1L); geta_("^NEW series or CONTINUE partially measured series /C", flinfo_1.qcm, 56L, 1L); } return 0; } /* 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 */ /* DOFILE */ /* Subroutine */ int prpfil_(logical *ok) { /* System generated locals */ address a__1[2]; integer i__1, i__2, i__3[2]; char ch__1[24]; cllist cl__1; /* Builtin functions */ integer i_indx(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio( integer *, char *, ftnlen), e_wsfe(void); /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); integer f_clos(cllist *); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen), geti_( char *, integer *, ftnlen); static integer nser; extern /* Subroutine */ int copy_(integer *, integer *); static integer j; extern integer largo_(char *, ftnlen); extern /* Subroutine */ int bp_(integer *, integer *, char *, ftnlen); static integer ll; static char qk[1]; extern /* Subroutine */ int openfi_(integer *, char *, char *, ftnlen, ftnlen), viewer_(char *, integer *, integer *, real *, ftnlen), listts_(char *, integer *, integer *, integer *, integer *, integer *, integer *, ftnlen); /* Fortran I/O blocks */ static cilist io___51 = { 0, 6, 0, "(' Copying original file to backup f" "ile ',A, '.BAK')", 0 }; static cilist io___53 = { 0, 6, 0, "(' Please wait while file is prepare" "d:'/)", 0 }; static cilist io___54 = { 0, 6, 0, "(' Start measuring ring',I6)", 0 }; for (j = 1; j <= 2048; ++j) { rarr_1.rm1[j - 1] = 0.f; rarr_1.rm2[j - 1] = 0.f; } *(unsigned char *)flinfo_1.qrm = ' '; if (*(unsigned char *)flinfo_1.qcm != 'C') { /* New series; get ident and first year.... */ L10: dates_1.nyr = 0; geta_("|Enter series ID", flinfo_1.qid, 16L, 8L); geti_("Date of first year to measure", &dates_1.jyr, 29L); dates_1.lyr = dates_1.jyr + dates_1.nyr - 1; geta_("^Are ID and year OK? /N", qk, 27L, 1L); if (*(unsigned char *)qk == 'N') { goto L10; } *ok = TRUE_; } else { /* Get series from existing file.... */ /* Computing MIN */ i__1 = i_indx(flinfo_1.q20, ".", 20L, 1L) - 1, i__2 = largo_( flinfo_1.q20, 20L); ll = min(i__1,i__2); s_wsfe(&io___51); do_fio(&c__1, flinfo_1.q20, ll); e_wsfe(); /* Writing concatenation */ i__3[0] = ll, a__1[0] = flinfo_1.q20; i__3[1] = 4, a__1[1] = ".BAK"; s_cat(ch__1, a__1, i__3, &c__2, 24L); openfi_(&flinfo_1.iub, ch__1, "N", ll + 4, 1L); copy_(&flinfo_1.iur, &flinfo_1.iub); openfi_(&flinfo_1.iur, flinfo_1.q20, "U", 20L, 1L); dates_1.nyr = 0; listts_(flinfo_1.qid, &dates_1.jyr, &dates_1.lyr, &dates_1.nyr, & flinfo_1.iub, &c__0, &c__0, 8L); bp_(&c__36, &c__40, " ", 1L); geti_("Sequence number of series to continue measuring", &nser, 47L); s_wsfe(&io___53); e_wsfe(); listts_(flinfo_1.qid, &dates_1.jyr, &dates_1.lyr, &dates_1.nyr, & flinfo_1.iub, &flinfo_1.iur, &nser, 8L); cl__1.cerr = 0; cl__1.cunit = flinfo_1.iur; cl__1.csta = 0; f_clos(&cl__1); openfi_(&flinfo_1.iur, flinfo_1.q20, "A", 20L, 1L); bp_(&c__33, &c__40, " ", 1L); viewer_(flinfo_1.qid, &dates_1.jyr, &dates_1.lyr, rarr_1.rm1, 8L); bp_(&c__32, &c__40, " ", 1L); s_wsfe(&io___54); i__1 = dates_1.lyr + 1; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfe(); geta_("^OK? /N", qk, 11L, 1L); *ok = *(unsigned char *)qk != 'N'; } return 0; } /* 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 */ /* PRPFIL */ /* Subroutine */ int nxtrng_(integer *nrng) { /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int bp_(integer *, integer *, char *, ftnlen); /* Fortran I/O blocks */ static cilist io___55 = { 0, 6, 0, "(' To correct a ring measurement in " "progress, ', 'set monitor display'/' value exactly equal t" "o last monitor', ' value on the screen, place sample at'/' start" " of ring, ', 'and remeasure.'//' To exit measuring, set monito" "r 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/)", 0 }; bp_(&c__32, &c__40, " ", 1L); s_wsfe(&io___55); do_fio(&c__1, (char *)&(*nrng), (ftnlen)sizeof(integer)); e_wsfe(); return 0; } /* 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 */ /* NXTRNG */ /* Subroutine */ int inmenu_(logical *noslct, logical *more, logical *done) { /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen), sale_( char *, ftnlen), geti_(char *, integer *, ftnlen); static char qint[1]; static integer idnum; extern /* Subroutine */ int bp_(integer *, integer *, char *, ftnlen); static char qk[1]; extern /* Subroutine */ int delmes_(char *, ftnlen), savmes_(logical *), insmes_(void), viewer_(char *, integer *, integer *, real *, ftnlen), skiprn_(integer *, logical *); static char qdd[1]; /* Fortran I/O blocks */ static cilist io___56 = { 0, 6, 0, "(' 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 c" "ontinue measuring')", 0 }; static cilist io___58 = { 0, 6, 0, "(' You may either:'/ " " ' (Y) remeasure to the end of the series, or'/" " ' (N) remeasure a part, leaving the latter val" "ues intact.')", 0 }; static cilist io___60 = { 0, 6, 0, "(' Series ',A,3I6,' years')", 0 }; static cilist io___63 = { 0, 6, 0, "(56X,'Unknown command!',A)", 0 }; *done = FALSE_; *more = TRUE_; bp_(&c__36, &c__40, " ", 1L); s_wsfe(&io___56); e_wsfe(); geta_("^Enter selection", qint, 16L, 1L); if (*(unsigned char *)qint == 'S') { savmes_(done); *more = FALSE_; *noslct = FALSE_; } else if (*(unsigned char *)qint == 'Z') { skiprn_(&dates_1.lyr, &c_true); *noslct = FALSE_; } else if (*(unsigned char *)qint == 'C') { skiprn_(&dates_1.lyr, &c_false); *noslct = FALSE_; } else if (*(unsigned char *)qint == 'R') { viewer_(flinfo_1.qid, &dates_1.jyr, &dates_1.lyr, rarr_1.rm1, 8L); dates_1.lyrm = dates_1.lyr; geti_("Remeasure rings starting with what year", &dates_1.lyr, 39L); s_wsfe(&io___58); e_wsfe(); geta_("Will you remeasure to the end? /N", flinfo_1.qrm, 37L, 1L); dates_1.nyr = dates_1.lyr - dates_1.jyr; --dates_1.lyr; skiprn_(&dates_1.lyr, &c_false); *noslct = FALSE_; } else if (*(unsigned char *)qint == 'X') { geta_("^Quit program without saving? Y/", qk, 36L, 1L); if (*(unsigned char *)qk == 'Y') { sale_("Quit", 4L); } } else if (*(unsigned char *)qint == 'I') { insmes_(); *noslct = TRUE_; } else if (*(unsigned char *)qint == 'V') { bp_(&c__35, &c__40, " ", 1L); viewer_(flinfo_1.qid, &dates_1.jyr, &dates_1.lyr, rarr_1.rm1, 8L); geta_("^Press key for INTERRUPT menu", qk, 29L, 1L); *noslct = TRUE_; } else if (*(unsigned char *)qint == 'D') { delmes_(flinfo_1.qid, 8L); s_wsfe(&io___60); do_fio(&c__1, flinfo_1.qid, 8L); do_fio(&c__1, (char *)&dates_1.jyr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&dates_1.lyr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&dates_1.nyr, (ftnlen)sizeof(integer)); e_wsfe(); *noslct = TRUE_; } else if (*(unsigned char *)qint == 'M') { geta_("^Enter direction to shift series: F: Forward B: Back in time" , qdd, 62L, 1L); geti_("Enter number of years to shift", &idnum, 30L); if (*(unsigned char *)qdd == 'F') { dates_1.jyr += idnum; dates_1.lyr += idnum; } else if (*(unsigned char *)qdd == 'B') { dates_1.jyr -= idnum; dates_1.lyr -= idnum; } *noslct = TRUE_; } else { s_wsfe(&io___63); do_fio(&c__1, "\a", 1L); e_wsfe(); *noslct = TRUE_; } return 0; } /* 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 */ /* INMENU */ /* Subroutine */ int savmes_(logical *done) { /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen); static char qk[1]; extern /* Subroutine */ int viewer_(char *, integer *, integer *, real *, ftnlen), trw_(char *, integer *, real *, integer *, integer *, char *, char *, ftnlen, ftnlen, ftnlen); /* Fortran I/O blocks */ static cilist io___65 = { 0, 6, 0, "(' Measurement series ',A,' saved in" " file')", 0 }; viewer_(flinfo_1.qid, &dates_1.jyr, &dates_1.lyr, rarr_1.rm1, 8L); geta_("^Save the current measurements? /N", qk, 38L, 1L); if (*(unsigned char *)qk != 'N') { if (*(unsigned char *)flinfo_1.qrm == 'N') { /* Part remeasured.... */ dates_1.lyr = dates_1.lyrm; dates_1.nyr = dates_1.lyr - dates_1.jyr + 1; } trw_(flinfo_1.qid, &dates_1.nyr, rarr_1.rm1, &dates_1.jyr, & flinfo_1.iur, flinfo_1.q20, flinfo_1.qq32, 8L, 20L, 1L); s_wsfe(&io___65); do_fio(&c__1, flinfo_1.qid, 8L); e_wsfe(); *(unsigned char *)flinfo_1.qcm = 'N'; geta_("^Will you measure another series? /N", qk, 40L, 1L); *done = *(unsigned char *)qk == 'N'; } return 0; } /* 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 */ /* SAVMES */ /* Subroutine */ int insmes_(void) { /* System generated locals */ integer i__1; /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen), geti_( char *, integer *, ftnlen), getr_(char *, real *, ftnlen); static real rwin; static integer inyr, j; static char qdd[1]; static integer isi; /* Fortran I/O blocks */ static cilist io___68 = { 0, 6, 0, "(40X,'(Give negative value to quit i" "nserting)')", 0 }; geti_("Year before which to insert value(s)", &inyr, 36L); geta_("^Direction to shift series: F: Forward : Back in time", qdd, 58L, 1L); s_wsfe(&io___68); e_wsfe(); L10: getr_("Enter value to insert", &rwin, 21L); if (rwin < 0.f) { goto L20; } isi = inyr - dates_1.jyr + 1; i__1 = isi; for (j = dates_1.nyr + 1; j >= i__1; --j) { rarr_1.rm1[j - 1] = rarr_1.rm1[j - 2]; } rarr_1.rm1[isi - 1] = rwin; ++dates_1.nyr; if (*(unsigned char *)qdd == 'F') { ++dates_1.lyr; ++inyr; } else { --dates_1.jyr; } goto L10; L20: return 0; } /* 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 */ /* INSMES */ /* Subroutine */ int delmes_(char *qid, ftnlen qid_len) { /* Initialized data */ static char qprmpt[64] = "^Direction to shift series: F: Forward : " "Back in time "; /* System generated locals */ integer i__1; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen), geti_( char *, integer *, ftnlen); static integer idyr1, idyr2, j, idnum; static char qk[1], qdd[1]; static integer isi; /* Fortran I/O blocks */ static cilist io___73 = { 0, 6, 0, "(/' Series ',A,3I6,' years')", 0 }; static cilist io___79 = { 0, 6, 0, "(' Deleting',I5,' measurements',I6,'" " to',I5)", 0 }; L10: s_wsfe(&io___73); do_fio(&c__1, qid, 8L); do_fio(&c__1, (char *)&dates_1.jyr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&dates_1.lyr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&dates_1.nyr, (ftnlen)sizeof(integer)); e_wsfe(); geti_("First year to delete", &idyr1, 20L); if (idyr1 < dates_1.jyr || idyr1 > dates_1.lyr) { *(unsigned char *)qk = 'Q'; } else { geti_("Last year to delete", &idyr2, 20L); geta_(qprmpt, qdd, 64L, 1L); idnum = idyr2 - idyr1 + 1; s_wsfe(&io___79); do_fio(&c__1, (char *)&idnum, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&idyr1, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&idyr2, (ftnlen)sizeof(integer)); e_wsfe(); geta_("^OK? /N", qk, 11L, 1L); } if (*(unsigned char *)qk == 'N') { goto L10; } if (*(unsigned char *)qk == 'Y') { isi = idyr1 - dates_1.jyr + 1; i__1 = dates_1.nyr - idnum; for (j = isi; j <= i__1; ++j) { rarr_1.rm1[j - 1] = rarr_1.rm1[j + idnum - 1]; } dates_1.nyr -= idnum; for (j = dates_1.nyr + 1; j <= 2048; ++j) { rarr_1.rm1[j - 1] = 0.f; } if (*(unsigned char *)qdd == 'F') { dates_1.jyr += idnum; } else { dates_1.lyr -= idnum; } } return 0; } /* 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 */ /* DELMES */ /* Subroutine */ int wrln_(char *lin, integer *io, ftnlen lin_len) { /* Initialized data */ static integer ios = 0; /* System generated locals */ integer i__1; olist o__1; alist al__1; /* Builtin functions */ integer f_open(olist *), f_rew(alist *), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ extern integer largo_(char *, ftnlen); static integer ll; /* Fortran I/O blocks */ static cilist io___84 = { 0, 0, 0, "(A)", 0 }; if (ios == 0) { ios = 63; o__1.oerr = 0; o__1.ounit = ios; o__1.ofnm = 0; o__1.orl = 8192; o__1.osta = "SCRATCH"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; f_open(&o__1); } *io = ios; ll = largo_(lin, lin_len); al__1.aerr = 1; al__1.aunit = *io; i__1 = f_rew(&al__1); if (i__1 != 0) { goto L1; } L1: io___84.ciunit = *io; s_wsfe(&io___84); do_fio(&c__1, lin, ll); e_wsfe(); al__1.aerr = 1; al__1.aunit = *io; i__1 = f_rew(&al__1); if (i__1 != 0) { goto L2; } L2: return 0; } /* 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 */ /* WRLN */ integer largo_(char *q, ftnlen q_len) { /* System generated locals */ integer ret_val; /* Builtin functions */ integer i_len(char *, ftnlen); /* Local variables */ static integer j, k, ll; ll = i_len(q, q_len); for (j = ll; j >= 1; --j) { k = *(unsigned char *)&q[j - 1]; if (k != 32 && k != 0) { ret_val = j; return ret_val; } } /* J loop */ ret_val = 1; return ret_val; } /* largo_ */ /* RTN BLANC: Blanks character string */ /* Programmed copyright (C) DEC 1986 by */ /* Richard L Holmes, Tucson, Arizona, USA */ /* Modified copyright (C) 04 AUG 1990 */ /* LARGO */ /* Subroutine */ int blanc_(char *l, ftnlen l_len) { /* System generated locals */ integer i__1; /* Builtin functions */ integer i_len(char *, ftnlen); /* Local variables */ static integer i__, ll; ll = i_len(l, l_len); i__1 = ll; for (i__ = 1; i__ <= i__1; ++i__) { *(unsigned char *)&l[i__ - 1] = ' '; } return 0; } /* 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. */ /* BLANC */ /* Subroutine */ int geta_(char *a, char *b, ftnlen a_len, ftnlen b_len) { /* Initialized data */ static char qp[4] = " => "; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_rsfe(cilist *), e_rsfe(void); /* Local variables */ extern /* Subroutine */ int sale_(char *, ftnlen), caps_(char *, ftnlen); static integer k; extern integer largo_(char *, ftnlen); static integer ll; /* Fortran I/O blocks */ static cilist io___92 = { 0, 6, 0, "(/1X,2A,$)", 0 }; static cilist io___93 = { 0, 6, 0, "(1X,2A,$)", 0 }; static cilist io___95 = { 0, 6, 0, "(' ')", 0 }; static cilist io___96 = { 0, 5, 0, "(A)", 0 }; extern int getch(void); char tempch; ll = largo_(a, a_len); if (*(unsigned char *)a == '|' || *(unsigned char *)a == '^') { s_wsfe(&io___92); do_fio(&c__1, a + 1, ll - 1); do_fio(&c__1, qp, 4L); e_wsfe(); } else { s_wsfe(&io___93); do_fio(&c__1, a, ll); do_fio(&c__1, qp, 4L); e_wsfe(); } if (*(unsigned char *)a == '^') { k = getch(); tempch = k; s_copy(b, &tempch, b_len, 1L); /* F K=ICHAR(B) */ if ((k < 32 || k > 126) && k != 9) { s_copy(b, " ", b_len, 1L); } s_wsfe(&io___95); e_wsfe(); } else { s_rsfe(&io___96); do_fio(&c__1, b, b_len); e_rsfe(); } if (*(unsigned char *)b == '/') { sale_(" ", 1L); } caps_(b, b_len); return 0; } /* 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 */ /* GETA */ /* Subroutine */ int geti_(char *lin, integer *i__, ftnlen lin_len) { /* Initialized data */ static char c2[3] = "[1A"; /* System generated locals */ integer i__1; /* Builtin functions */ integer s_rsli(icilist *), do_lio(integer *, integer *, char *, ftnlen), e_rsli(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen); extern integer largo_(char *, ftnlen); static integer ll; static char lne[10]; /* Fortran I/O blocks */ static icilist io___100 = { 1, lne, 1, 0, 10, 1 }; static cilist io___101 = { 0, 6, 0, "(1X,2A,70(' '),T73,'INTEGER!',3A)", 0 }; /* Integer */ L1: geta_(lin, lne, lin_len, 10L); ll = largo_(lne, 10L); /* Read character string */ /* `P+ CALL WRLN(LNE,IOS) */ /* `P+ READ(IOS,*,ERR=98,END=98)I */ /* `P- */ i__1 = s_rsli(&io___100); if (i__1 != 0) { goto L98; } i__1 = do_lio(&c__3, &c__1, (char *)&(*i__), (ftnlen)sizeof(integer)); if (i__1 != 0) { goto L98; } i__1 = e_rsli(); if (i__1 != 0) { goto L98; } return 0; /* Set null string to zero or error message */ L98: if (ll <= 1 && *(unsigned char *)lne == ' ') { *i__ = 0; return 0; } s_wsfe(&io___101); do_fio(&c__1, "\033", 1L); do_fio(&c__1, c2, 3L); do_fio(&c__1, "\033", 1L); do_fio(&c__1, c2, 3L); do_fio(&c__1, "\a", 1L); e_wsfe(); goto L1; } /* 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 */ /* GETI */ /* Subroutine */ int getr_(char *lin, real *r__, ftnlen lin_len) { /* Initialized data */ static char c2[3] = "[1A"; /* System generated locals */ integer i__1; /* Builtin functions */ integer s_rsli(icilist *), do_lio(integer *, integer *, char *, ftnlen), e_rsli(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen); extern integer largo_(char *, ftnlen); static integer ll; static char lne[10]; /* Fortran I/O blocks */ static icilist io___105 = { 1, lne, 1, 0, 10, 1 }; static cilist io___106 = { 0, 6, 0, "(1X,2A,70(' '),T74,'NUMBER!',3A)", 0 }; L1: geta_(lin, lne, lin_len, 10L); ll = largo_(lne, 10L); /* Read character string */ /* `P+ CALL WRLN(LNE,IOS) */ /* `P+ READ(IOS,*,ERR=98,END=98)R */ /* `P- */ i__1 = s_rsli(&io___105); if (i__1 != 0) { goto L98; } i__1 = do_lio(&c__4, &c__1, (char *)&(*r__), (ftnlen)sizeof(real)); if (i__1 != 0) { goto L98; } i__1 = e_rsli(); if (i__1 != 0) { goto L98; } return 0; /* Set null string to zero or error message */ L98: if (ll <= 1 && *(unsigned char *)lne == ' ') { *r__ = 0.f; return 0; } s_wsfe(&io___106); do_fio(&c__1, "\033", 1L); do_fio(&c__1, c2, 3L); do_fio(&c__1, "\033", 1L); do_fio(&c__1, c2, 3L); do_fio(&c__1, "\a", 1L); e_wsfe(); goto L1; } /* 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 */ /* GETR */ /* Subroutine */ int caps_(char *l, ftnlen l_len) { /* Initialized data */ static integer la = 97; static integer lz = 122; static integer ld = -32; /* System generated locals */ integer i__1; /* Builtin functions */ integer i_len(char *, ftnlen); /* Local variables */ static integer i__, k, ll; ll = i_len(l, l_len); i__1 = ll; for (i__ = 1; i__ <= i__1; ++i__) { k = *(unsigned char *)&l[i__ - 1]; if (k >= la && k <= lz) { *(unsigned char *)&l[i__ - 1] = (char) (k + ld); } } return 0; } /* 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' */ /* CAPS */ /* Subroutine */ int trw_(char *qid, integer *n, real *y, integer *jyr, integer *io, char *q20, char *qf, ftnlen qid_len, ftnlen q20_len, ftnlen qf_len) { /* System generated locals */ integer i__1, i__2; real r__1, r__2; cllist cl__1; /* Builtin functions */ /* Subroutine */ int s_stop(char *, ftnlen); integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void), s_rsfi(icilist *), e_rsfi(void); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer i_nint(real *), s_wsfe(cilist *), e_wsfe(void), f_clos(cllist *); /* Local variables */ static char qida[8]; static real cons; static integer i__, j, k, l; extern integer largo_(char *, ftnlen); static integer ii; static real yd[10]; extern /* Subroutine */ int openfi_(integer *, char *, char *, ftnlen, ftnlen); static integer ier; static char lin[80]; static integer iyd[10], isw, kyr, jyr1; /* Fortran I/O blocks */ static cilist io___116 = { 1, 0, 1, "(A)", 0 }; static icilist io___118 = { 1, lin, 1, "(A,I5,10F6.2)", 80, 1 }; static icilist io___122 = { 1, lin, 1, "(A,I4,10F6.2)", 80, 1 }; static cilist io___129 = { 0, 0, 0, "(A,I5,10I6)", 0 }; static cilist io___131 = { 0, 0, 0, "(A,I4,10I6)", 0 }; /* DATA QT/' '/ */ /* Find what action to do */ /* Parameter adjustments */ --y; /* Function Body */ if (*(unsigned char *)qf != 'R') { /* Precision .001 */ if (*(unsigned char *)qf == '3') { cons = 1e3f; /* Precision .01 */ } else { cons = 100.f; } goto L5; } *n = 0; isw = 0; ier = 0; /* Read line from file */ goto L1; L91: ++ier; if (ier > 25) { s_stop(">> Sbr TRW: Text over 25 lines", 31L); } L1: io___116.ciunit = *io; i__1 = s_rsfe(&io___116); if (i__1 != 0) { goto L99; } i__1 = do_fio(&c__1, lin, 80L); if (i__1 != 0) { goto L99; } i__1 = e_rsfe(); if (i__1 != 0) { goto L99; } if (largo_(lin, 80L) <= 8) { goto L1; } /* Read measurements */ if (*(unsigned char *)qf == 'R') { if (*(unsigned char *)&lin[7] == '-') { i__1 = s_rsfi(&io___118); if (i__1 != 0) { goto L100001; } i__1 = do_fio(&c__1, qida, 7L); if (i__1 != 0) { goto L100001; } i__1 = do_fio(&c__1, (char *)&jyr1, (ftnlen)sizeof(integer)); if (i__1 != 0) { goto L100001; } i__1 = do_fio(&c__10, (char *)&yd[0], (ftnlen)sizeof(real)); if (i__1 != 0) { goto L100001; } i__1 = e_rsfi(); L100001: if (i__1 < 0) { goto L99; } if (i__1 > 0) { goto L91; } *(unsigned char *)&qida[7] = ' '; } else { i__1 = s_rsfi(&io___122); if (i__1 != 0) { goto L100002; } i__1 = do_fio(&c__1, qida, 8L); if (i__1 != 0) { goto L100002; } i__1 = do_fio(&c__1, (char *)&jyr1, (ftnlen)sizeof(integer)); if (i__1 != 0) { goto L100002; } i__1 = do_fio(&c__10, (char *)&yd[0], (ftnlen)sizeof(real)); if (i__1 != 0) { goto L100002; } i__1 = e_rsfi(); L100002: if (i__1 < 0) { goto L99; } if (i__1 > 0) { goto L91; } } } ++isw; l = 10; if (isw == 1) { s_copy(qid, qida, qid_len, 8L); *jyr = jyr1; if (*jyr >= 0) { l = 10 - *jyr % 10; } else { l = (i__1 = *jyr % 10, abs(i__1)); if (l == 0) { l = 10; } } } if (*(unsigned char *)qf == 'R') { goto L3; } l = 11 - l; for (i__ = l; i__ <= 10; ++i__) { if (yd[i__ - 1] < 9.99f) { ++(*n); y[*n] = yd[i__ - 1]; } else { goto L999; } /* L10: */ } goto L1; L99: *n = 0; goto L999; /* Ring measurement */ L3: i__1 = l; for (i__ = 1; i__ <= i__1; ++i__) { /* End flag reached */ if ((r__1 = yd[i__ - 1] - 9.99f, dabs(r__1)) < 1e-4f || (r__2 = yd[ i__ - 1] + 99.99f, dabs(r__2)) < 1e-4f) { /* If end flag is -9999, precision is .001 mm */ if (yd[i__ - 1] < -99.98f) { i__2 = *n; for (ii = 1; ii <= i__2; ++ii) { y[ii] *= .1f; } } goto L999; } ++(*n); y[*n] = yd[i__ - 1]; } /* I loop */ goto L1; L5: if (*n <= 0) { goto L999; } ier = 0; j = 0; kyr = *jyr; /* L4: */ if (*jyr >= 0) { l = 10 - *jyr % 10; } else { l = (i__1 = *jyr % 10, abs(i__1)); if (l == 0) { l = 10; } } L42: i__1 = l; for (i__ = 1; i__ <= i__1; ++i__) { ++j; if (j > *n) { /* Precision .001 */ if (*(unsigned char *)qf == '3') { iyd[i__ - 1] = -9999; /* Precision .01 */ } else { iyd[i__ - 1] = 999; } l = i__; j = -999; goto L51; } else { r__1 = y[j] * cons; iyd[i__ - 1] = i_nint(&r__1); if (iyd[i__ - 1] == 999) { iyd[i__ - 1] = 998; } } } L51: if (kyr < -999) { io___129.ciunit = *io; s_wsfe(&io___129); do_fio(&c__1, qid, 7L); do_fio(&c__1, (char *)&kyr, (ftnlen)sizeof(integer)); i__1 = l; for (k = 1; k <= i__1; ++k) { do_fio(&c__1, (char *)&iyd[k - 1], (ftnlen)sizeof(integer)); } e_wsfe(); } else { io___131.ciunit = *io; s_wsfe(&io___131); do_fio(&c__1, qid, 8L); do_fio(&c__1, (char *)&kyr, (ftnlen)sizeof(integer)); i__1 = l; for (k = 1; k <= i__1; ++k) { do_fio(&c__1, (char *)&iyd[k - 1], (ftnlen)sizeof(integer)); } e_wsfe(); } if (j < 0) { goto L999; } kyr += l; l = 10; goto L42; L999: if (*(unsigned char *)qf != 'R' && *(unsigned char *)q20 != '!') { cl__1.cerr = 0; cl__1.cunit = *io; cl__1.csta = 0; f_clos(&cl__1); openfi_(io, q20, "A", 20L, 1L); } return 0; } /* 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 */ /* TRW */ /* Subroutine */ int openfi_(integer *io, char *qfl, char *qt, ftnlen qfl_len, ftnlen qt_len) { /* System generated locals */ integer i__1; olist o__1; /* Builtin functions */ integer f_open(olist *), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Subroutine */ int s_stop(char *, ftnlen); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen), qfill_( char *, ftnlen); static char qo[1]; /* Fortran I/O blocks */ static cilist io___132 = { 0, 6, 0, "(' Cannot open new file ',A/ " " ' Overwrite existing file or give new file n" "ame',A)", 0 }; static cilist io___134 = { 0, 6, 0, "(' Error opening file ',2A)", 0 }; L1: qfill_(qfl, qfl_len); /* New file */ if (*(unsigned char *)qt == 'N') { /* ? OPEN(IO,FILE=QFL,STATUS='NEW',RECL=2048,ERR=2) */ o__1.oerr = 1; o__1.ounit = *io; o__1.ofnmlen = qfl_len; o__1.ofnm = qfl; o__1.orl = 0; o__1.osta = "NEW"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L2; } return 0; /* Ask if file should be overwritten */ L2: s_wsfe(&io___132); do_fio(&c__1, qfl, qfl_len); do_fio(&c__1, "\a", 1L); e_wsfe(); geta_("Overwrite existing file? /N", qo, 31L, 1L); if (*(unsigned char *)qo == 'N') { geta_(" ... Name of NEW file to create", qfl, 32L, qfl_len); qfill_(qfl, qfl_len); /* ? OPEN(IO,FILE=QFL,STATUS='NEW',RECL=2048,ERR=2) */ o__1.oerr = 1; o__1.ounit = *io; o__1.ofnmlen = qfl_len; o__1.ofnm = qfl; o__1.orl = 0; o__1.osta = "NEW"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L2; } } else { /* ? OPEN(IO,FILE=QFL,STATUS='UNKNOWN',RECL=2048,ERR=2) */ o__1.oerr = 1; o__1.ounit = *io; o__1.ofnmlen = qfl_len; o__1.ofnm = qfl; o__1.orl = 0; o__1.osta = "UNKNOWN"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L2; } } } else if (*(unsigned char *)qt == 'O') { o__1.oerr = 1; o__1.ounit = *io; o__1.ofnmlen = qfl_len; o__1.ofnm = qfl; o__1.orl = 0; o__1.osta = "OLD"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L98; } } else if (*(unsigned char *)qt == 'A') { o__1.oerr = 1; o__1.ounit = *io; o__1.ofnmlen = qfl_len; o__1.ofnm = qfl; o__1.orl = 0; o__1.osta = "OLD"; o__1.oacc = "APPEND"; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L98; } /* ## OPEN(IO,FILE=QFL,STATUS='OLD',ACCESS='APPEND',ERR=7) */ /* ## RETURN */ /* ## 7 OPEN(IO,FILE=QFL,STATUS='NEW',ERR=98) */ } else if (*(unsigned char *)qt == 'U') { o__1.oerr = 1; o__1.ounit = *io; o__1.ofnmlen = qfl_len; o__1.ofnm = qfl; o__1.orl = 0; o__1.osta = "UNKNOWN"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L98; } } else if (*(unsigned char *)qt == 'S') { /* ? OPEN(IO,STATUS='SCRATCH',RECL=2048,ERR=97) */ o__1.oerr = 1; o__1.ounit = *io; o__1.ofnm = 0; o__1.orl = 0; o__1.osta = "SCRATCH"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L97; } } else if (*(unsigned char *)qt == 'D') { o__1.oerr = 1; o__1.ounit = *io; o__1.ofnm = 0; o__1.orl = 4096; o__1.osta = "SCRATCH"; o__1.oacc = "DIRECT"; o__1.ofm = 0; o__1.oblnk = 0; i__1 = f_open(&o__1); if (i__1 != 0) { goto L97; } } return 0; L98: s_wsfe(&io___134); do_fio(&c__1, qfl, qfl_len); do_fio(&c__1, "\a", 1L); e_wsfe(); geta_(" ... Name of EXISTING file to open", qfl, 35L, qfl_len); goto L1; L97: s_stop("Error opening scratch file", 26L); return 0; } /* 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 */ /* OPENFI */ /* Subroutine */ int qfill_(char *ql, ftnlen ql_len) { /* System generated locals */ integer i__1; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static integer i__; extern /* Subroutine */ int blanc_(char *, ftnlen); extern integer largo_(char *, ftnlen); static integer ll, ns; static char qz[32]; ll = largo_(ql, ql_len); blanc_(qz, 32L); ns = 0; i__1 = ll; for (i__ = 1; i__ <= i__1; ++i__) { if (*(unsigned char *)&ql[i__ - 1] != 32 && *(unsigned char *)&ql[i__ - 1] != 0) { ++ns; *(unsigned char *)&qz[ns - 1] = *(unsigned char *)&ql[i__ - 1]; } } /* I loop */ s_copy(ql, qz, ql_len, 32L); return 0; } /* 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 */ /* QFILL */ /* Subroutine */ int copy_(integer *ir, integer *iw) { /* System generated locals */ integer i__1; cllist cl__1; alist al__1; /* Builtin functions */ integer f_rew(alist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void), s_wsfe(cilist *), e_wsfe(void), f_clos( cllist *); /* Local variables */ static integer j; extern integer largo_(char *, ftnlen); static char lin[84]; /* Fortran I/O blocks */ static cilist io___139 = { 1, 0, 1, "(A)", 0 }; static cilist io___142 = { 0, 0, 0, "(A)", 0 }; if (*ir == *iw) { return 0; } al__1.aerr = 0; al__1.aunit = *ir; f_rew(&al__1); L1: io___139.ciunit = *ir; i__1 = s_rsfe(&io___139); if (i__1 != 0) { goto L99; } i__1 = do_fio(&c__1, lin, 84L); if (i__1 != 0) { goto L99; } i__1 = e_rsfe(); if (i__1 != 0) { goto L99; } j = largo_(lin, 84L); io___142.ciunit = *iw; s_wsfe(&io___142); do_fio(&c__1, lin, j); e_wsfe(); goto L1; L99: cl__1.cerr = 0; cl__1.cunit = *ir; cl__1.csta = 0; f_clos(&cl__1); return 0; } /* 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 */ /* COPY */ /* Subroutine */ int viewer_(char *qid, integer *jyr, integer *lyr, real *y, ftnlen qid_len) { /* System generated locals */ integer y_offset, i__1; real r__1; icilist ici__1; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void), s_wsfi(icilist *), i_nint(real *), e_wsfi(void); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen); static integer i__, j, k, m; extern /* Subroutine */ int blanc_(char *, ftnlen); static char q[1]; extern /* Subroutine */ int bp_(integer *, integer *, char *, ftnlen); static integer nl, jy; static char qz[7*10]; /* Fortran I/O blocks */ static cilist io___143 = { 0, 6, 0, "(/1X,A,I6,9I7)", 0 }; static cilist io___145 = { 0, 6, 0, "(13X,'-0',9I7)", 0 }; static cilist io___152 = { 0, 6, 0, "(I7,2X,10A)", 0 }; static cilist io___154 = { 0, 6, 0, "(1X,A,I6,9I7)", 0 }; /* Print heading */ /* Parameter adjustments */ y_offset = *jyr; y -= y_offset; /* Function Body */ bp_(&c__33, &c__40, " ", 1L); s_wsfe(&io___143); do_fio(&c__1, qid, 8L); for (k = 0; k <= 9; ++k) { do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); } e_wsfe(); if (*jyr < -10) { s_wsfe(&io___145); for (k = -9; k <= -1; ++k) { do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); } e_wsfe(); } j = *jyr - 1; jy = *jyr; nl = 0; L2: for (i__ = 1; i__ <= 10; ++i__) { blanc_(qz + (i__ - 1) * 7, 7L); } L1: ++j; /* Find place for data */ if (j >= 0) { m = j % 10 + 1; } else { m = 11 - abs(j) % 10; if (m == 11) { m = 1; } } ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 7; ici__1.iciunit = qz + (m - 1) * 7; ici__1.icifmt = "(I7)"; s_wsfi(&ici__1); r__1 = y[j] * 1e3f; i__1 = i_nint(&r__1); do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfi(); if (m == 10 || j == *lyr) { s_wsfe(&io___152); do_fio(&c__1, (char *)&jy, (ftnlen)sizeof(integer)); do_fio(&c__10, qz, 7L); e_wsfe(); if (j >= *lyr) { return 0; } jy = j + 1; ++nl; if (nl % 20 == 0) { geta_("^Press key for more", q, 19L, 1L); bp_(&c__33, &c__40, " ", 1L); s_wsfe(&io___154); do_fio(&c__1, qid, 8L); for (k = 0; k <= 9; ++k) { do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); } e_wsfe(); } goto L2; } goto L1; } /* 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 */ /* VIEWER */ /* Subroutine */ int listts_(char *qil, integer *jyr, integer *lyr, integer * nyr, integer *iu, integer *iun, integer *nget, ftnlen qil_len) { /* System generated locals */ integer i__1; alist al__1; /* Builtin functions */ integer f_rew(alist *), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ extern /* Subroutine */ int geta_(char *, char *, ftnlen, ftnlen); static integer nser, i__; static char q[1]; static integer jy, ly, ny; static char qid[8]; extern /* Subroutine */ int trw_(char *, integer *, real *, integer *, integer *, char *, char *, ftnlen, ftnlen, ftnlen); /* Fortran I/O blocks */ static cilist io___161 = { 0, 6, 0, "(I6,2X,A,3I6)", 0 }; static cilist io___163 = { 0, 6, 0, "('+',I5,2X,A)", 0 }; al__1.aerr = 0; al__1.aunit = *iu; f_rew(&al__1); nser = 0; L1: trw_(qid, &ny, rarr_1.rm2, &jy, iu, "!", "R", 8L, 1L, 1L); if (ny <= 0) { goto L2; } ++nser; ly = jy + ny - 1; /* List series if NGET is 0 */ if (*nget <= 0) { if (nser % 20 == 1 && nser > 1) { geta_("^Press key for more, `N` to quit list", q, 37L, 1L); if (*(unsigned char *)q == 'N') { goto L2; } } s_wsfe(&io___161); do_fio(&c__1, (char *)&nser, (ftnlen)sizeof(integer)); do_fio(&c__1, qid, 8L); do_fio(&c__1, (char *)&jy, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ly, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ny, (ftnlen)sizeof(integer)); e_wsfe(); } if (nser == *nget) { *jyr = jy; *lyr = ly; *nyr = ny; s_copy(qil, qid, 8L, 8L); i__1 = *nyr; for (i__ = 1; i__ <= i__1; ++i__) { rarr_1.rm1[i__ - 1] = rarr_1.rm2[i__ - 1]; } /* I loop */ } else if (*iun > 0) { trw_(qid, &ny, rarr_1.rm2, &jy, iun, "!", "3", 8L, 1L, 1L); s_wsfe(&io___163); do_fio(&c__1, (char *)&nser, (ftnlen)sizeof(integer)); do_fio(&c__1, qid, 8L); e_wsfe(); } goto L1; L2: if (*nget <= 0) { al__1.aerr = 0; al__1.aunit = *iu; f_rew(&al__1); } return 0; } /* 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 */ /* LISTTS */ /* Subroutine */ int comlog_(char *q16, char *qmsg, ftnlen q16_len, ftnlen qmsg_len) { /* Initialized data */ static char q[1] = " "; /* System generated locals */ cllist cl__1; /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen), f_clos(cllist *); /* Local variables */ extern /* Subroutine */ int openfi_(integer *, char *, char *, ftnlen, ftnlen); /* Fortran I/O blocks */ static cilist io___165 = { 0, 14, 0, "('*** Start new COM.LOG file ***')", 0 }; static cilist io___166 = { 0, 14, 0, "(2A)", 0 }; openfi_(&c__14, "COM.LOG", "A", 7L, 1L); if (*(unsigned char *)&q[0] == ' ') { s_wsfe(&io___165); e_wsfe(); } *(unsigned char *)&q[0] = 'C'; s_wsfe(&io___166); do_fio(&c__1, q16, 16L); do_fio(&c__1, qmsg, qmsg_len); e_wsfe(); cl__1.cerr = 0; cl__1.cunit = 14; cl__1.csta = 0; f_clos(&cl__1); return 0; } /* 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 */ /* COMLOG */ /* Subroutine */ int bp_(integer *ka, integer *kb, char *q, ftnlen q_len) { /* Initialized data */ static integer lb = 43; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ static integer m; /* Fortran I/O blocks */ static cilist io___168 = { 0, 6, 0, "(1X,A,'[0;1;',I2,';',I2,'m')", 0 }; static cilist io___169 = { 0, 6, 0, "(/1X,A,'[2J',A,'[H')", 0 }; s_wsfe(&io___168); do_fio(&c__1, "\033", 1L); do_fio(&c__1, (char *)&(*ka), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*kb), (ftnlen)sizeof(integer)); e_wsfe(); if (*(unsigned char *)q == 'B' || *(unsigned char *)q != 'N' && lb != 40) { s_wsfe(&io___169); for (m = 1; m <= 2; ++m) { do_fio(&c__1, "\033", 1L); } e_wsfe(); } lb = *kb; return 0; } /* 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 */ /* BP */ /* Subroutine */ int sale_(char *qlin, ftnlen qlin_len) { /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Subroutine */ int s_stop(char *, ftnlen); /* Local variables */ extern /* Subroutine */ int bp_(integer *, integer *, char *, ftnlen); /* Fortran I/O blocks */ static cilist io___171 = { 0, 6, 0, "(/1X,A)", 0 }; bp_(&c__37, &c__44, " ", 1L); if (*(unsigned char *)qlin != ' ') { s_wsfe(&io___171); do_fio(&c__1, qlin, qlin_len); e_wsfe(); } s_stop("- = [ MEDIR ] = -", 19L); return 0; } /* sale_ */