c--rdcat-csv reads HVO catalog files in comma delimited format (.csv)
c--A separate parsing subroutine must read lines to separate fields.
c--This is because imbedded spaces and
c  slashes in strings are seperators in fortran's automatic parser.

c--comment fields in output summary file
c  #1  X region is totally unknown, defaults to "Kilauea"
c  #1  X region is only generally known ie "east Hawaii"
c  #1  * lat/lon is that of center of region to which event is assigned
c  #2  ? region was questioned with mild (?) or major (??) uncertainty
c  #3  F felt, no intensity assignable
c  #3  2-9,A-C: maximum MM intensity II-IX, X=XII
c  #4  XXX  Geographic region code

c--errors for which event is not output:
c*** Bad line (unreadable):
c*** Bad date (unreadable):
c*** Bad date (missing):
c*** Bad time (unreadable):
c*** Bad mag (unreadable):
c*** Blank line?:
c*** Bad lat (unreadable):
c*** Bad lon (unreadable):
c*** Bad value for number of fields

c--errors for which some assumption is made and event is output:
c%%% Found unknown region name (leave blank):
c%%% Found unknown magnitude type (leave blank):
c%%% Events out of chron order:
c%%% Found bad intensity (leave blank):
c%%% No time (assume 12h 0m):
c%%% Magnitude source but no magnitude:
c%%% Magnitude but no mag source:

c--event is output but error messages are suppressible
c--- Only XX fields found, pad with blank fields:
c--- No region for event, leave blank:
c--- Bad time (assume 12h 0m):

	character line*600, llast*600, erfl*60, cmtfl*60, star*1
c	character c5*5, c1*1
	character cquest*1, cint*10,cint1*1
	character field(26)*90
	character*90 fdate,ftime, flatd,flatm,flond,flonm, freg,fdep
	character*90 fpmag,fpmags
	character title(26)*90
	dimension len(26), icom(26)
	double precision t,tlast
	logical lmult,assumed,lfull, lwarn, lclean
c	logical ldrop

c--initialize these for short formats where they arent specified
	data lenlatd,lenlatm,lenlond,lenlonm,lenclass /5*0/
	data flatd,flatm,flond,flonm /4*' '/

c--date and time values
	character cdate(3)*90,ctime(3)*90
	dimension lendate(3),lentime(3), idate(3),itime(3)

	real      latd
	real      latm
	real      lond
	real      lonm
	character region*25, regn3*3
	data ieqsl,icount,erfl,cmtfl,lmult /2*0,'.err','.cmt',.false./

c--these names are the recognized regions and are translated to a 3-letter name
	parameter (nreg=105)
	character reg(nreg)*25,reg3(nreg)*3

c-region names
	data reg(01),reg3(01) /'loihi','LOI'/
	data reg(02),reg3(02) /'kl gln','GLN'/
	data reg(03),reg3(03) /'kl cal 0-5','CAL'/
	data reg(04),reg3(04) /'kl cal 05-10','INT'/
	data reg(69),reg3(69) /'kl cal 10-20','INT'/
	data reg(05),reg3(05) /'kl uer','UER'/
	data reg(105),reg3(105) /' kl uer','UER'/
	data reg(06),reg3(06) /'kl mer','MER'/
	data reg(07),reg3(07) /'kl ler','LER'/
	data reg(09),reg3(09) /'kl swr','SWR'/
	data reg(08),reg3(08) /'kl koae','KOA'/
	data reg(10),reg3(10) /'kl sf','SFL'/
	data reg(11),reg3(11) /'kl ler sf','SF4'/
	data reg(12),reg3(12) /'kl mer sf','SF3'/
	data reg(13),reg3(13) /'kl kuer sf','SF2'/
	data reg(14),reg3(14) /'kl swr sf','SF1'/
	data reg(16),reg3(16) /'ml mok','MOK'/
	data reg(17),reg3(17) /'ml ner','MNE'/
	data reg(18),reg3(18) /'ml nf','MNF'/
	data reg(19),reg3(19) /'ml swr','MSW'/
	data reg(20),reg3(20) /'kaoiki','KAO'/
	data reg(21),reg3(21) /'hilea','HLE'/
	data reg(22),reg3(22) /'milolii','MIL'/
	data reg(93),reg3(93) /'milolii os','MIL'/
	data reg(23),reg3(23) /'kona','KON'/
	data reg(82),reg3(82) /'kona os','OKO'/
	data reg(24),reg3(24) /'ml wf','MWF'/
	data reg(25),reg3(25) /'hilo','HIL'/
	data reg(83),reg3(83) /'hilo os','HIL'/
	data reg(26),reg3(26) /'hualalai','HUA'/
	data reg(27),reg3(27) /'hualalai os','OHU'/	
	data reg(28),reg3(28) /'mauna kea','KEA'/
	data reg(29),reg3(29) /'mauna kea os','MKO'/
	data reg(31),reg3(31) /'kohala','KOH'/
	data reg(32),reg3(32) /'kohala os','ALE'/
	data reg(33),reg3(33) /'alenuihaha','ALE'/
	data reg(34),reg3(34) /'maui','MAU'/
	data reg(35),reg3(35) /'maui east','MAE'/
	data reg(54),reg3(54) /'maui deep','MAU'/
	data reg(36),reg3(36) /'lanai','MOL'/
	data reg(37),reg3(37) /'molokai','MOL'/
	data reg(91),reg3(91) /'molokai os','MOL'/
	data reg(38),reg3(38) /'oahu','OAH'/
	data reg(77),reg3(77) /'se oahu','OAH'/
	data reg(85),reg3(85) /'lanai se','MAU'/
	data reg(86),reg3(86) /'lanai nw','MOL'/
	data reg(73),reg3(73) /'sw of lanai','DIS'/

	data reg(55),reg3(55) /'kl ler os','SFO'/
	data reg(56),reg3(56) /'kl sf os','SFO'/
	data reg(57),reg3(57) /'kl ler sf os','SFO'/
	data reg(58),reg3(58) /'kl mer sf os','SFO'/
	data reg(65),reg3(65) /'kl mer sf  os','SFO'/
	data reg(59),reg3(59) /'kl kuer sf os','SFO'/
	data reg(60),reg3(60) /'kl swr sf os','SFO'/
	data reg(66),reg3(66) /'kl swr os','SFO'/
	data reg(90),reg3(90) /'hilea os','SFO'/

c--generalized areas
	data reg(39),reg3(39) /'hawaii','HAW'/
	data reg(97),reg3(97) /'kilauea','KIL'/
	data reg(15),reg3(15) /'mauna loa','MLO'/
	data reg(98),reg3(98) /'south hawaii','SHA'/
	data reg(99),reg3(99) /'west hawaii','WHA'/
	data reg(100),reg3(100) /'north hawaii','NHA'/
	data reg(101),reg3(101) /'east hawaii','EHA'/
	data reg(30),reg3(30) /'kauai','DIS'/
	data reg(95),reg3(95) /'sw of kahoolawe','DIS'/
	data reg(102),reg3(102) /'off chain','DIS'/
	data reg(84),reg3(84) /'a0513','A05'/
	data reg(78),reg3(78) /'a1320','A13'/
	data reg(80),reg3(80) /'a2025','A20'/
	data reg(92),reg3(92) /'a2530','A25'/
	data reg(94),reg3(94) /'a3035','A30'/
	data reg(103),reg3(103) /'a3540','A35'/

c--deep regions	
	data reg(40),reg3(40) /'kl cal deep','DEP'/
	data reg(76),reg3(76) /'kl uer deep','DEP'/
	data reg(72),reg3(72) /'kl gln deep','DEP'/
	data reg(41),reg3(41) /'kl koae deep','DEP'/
	data reg(43),reg3(43) /'mauna loa deep','DML'/
	data reg(44),reg3(44) /'ml nf deep','DML'/
	data reg(96),reg3(96) /'ml wf deep','DKO'/
	data reg(45),reg3(45) /'ml ner deep','DML'/
	data reg(88),reg3(88) /'ml mok deep','DML'/
	data reg(46),reg3(46) /'mlner deep','DML'/
	data reg(87),reg3(87) /'kaoiki deep','DML'/
	data reg(47),reg3(47) /'hilea deep','DLS'/
	data reg(68),reg3(68) /'kl swr deep','DLS'/
	data reg(70),reg3(70) /'kl swr os deep','DLS'/
	data reg(71),reg3(71) /'kl swr sf deep','DLS'/
	data reg(42),reg3(42) /'kl swr sf os deep','DLS'/
	data reg(89),reg3(89) /'ml swr deep','DLS'/
	data reg(49),reg3(49) /'hilo deep','DHI'/
	data reg(50),reg3(50) /'mauna kea deep','DKE'/
	data reg(51),reg3(51) /'hualalai deep','DHU'/
	data reg(52),reg3(52) /'kona deep','DKO'/
	data reg(53),reg3(53) /'kohala deep','DKH'/
	data reg(81),reg3(81) /'mauna kea os deep','MKO'/
	data reg(48),reg3(48) /'alenuihaha deep','ALE'/

	data reg(61),reg3(61) /'kl mer deep','DER'/
	data reg(62),reg3(62) /'kl mer sf deep','DER'/
	data reg(63),reg3(63) /'kl kuer sf deep','DER'/
	data reg(67),reg3(67) /'kl sf deep','DER'/
	data reg(64),reg3(64) /'kl kuer sf os deep','DER'/
	data reg(104),reg3(104) /'kl mer sf os deep','DER'/
	data reg(74),reg3(74) /'kl ler deep','DLE'/
	data reg(75),reg3(75) /'kl ler os deep','DLE'/
	data reg(79),reg3(79) /'kl ler sf deep','DLE'/


c--magnitude type codes
	parameter (nmtyp=12)
	dimension ilenty(nmtyp)
	character mtyp(nmtyp)*4,mcode(nmtyp)*1, magtyp*20,pmtyp*1
	data mtyp(01),mcode(01),ilenty(01) /'hono','H',4/
	data mtyp(11),mcode(11),ilenty(11) /'calc','C',4/
	data mtyp(02),mcode(02),ilenty(02) /'nomo','N',4/
	data mtyp(03),mcode(03),ilenty(03) /'gute','S',4/
	data mtyp(04),mcode(04),ilenty(04) /'hvo ','L',3/
	data mtyp(05),mcode(05),ilenty(05) /'ind ','E',3/
	data mtyp(10),mcode(10),ilenty(10) /'w&k ','I',3/
	data mtyp(06),mcode(06),ilenty(06) /'int ','M',3/
	data mtyp(12),mcode(12),ilenty(12) /'felt','F',4/
	data mtyp(08),mcode(08),ilenty(08) /'aver','A',4/
	data mtyp(09),mcode(09),ilenty(09) /'poor','P',4/
	data mtyp(07),mcode(07),ilenty(07) /'desp','D',4/
c	data mtyp(),mcode() /'',''/

c--region center coordinates
	parameter (lreg=46)
	character rt*3
	dimension rt(lreg),ltd(lreg),ltm(lreg),lnd(lreg),lnm(lreg)
C	data rt(0$),ltd(0$),ltm(0$),lnd(0$),lnm(0$)/'

	data rt(01),ltd(01),ltm(01),lnd(01),lnm(01)/'CAL',19,24,155,16/
	data rt(02),ltd(02),ltm(02),lnd(02),lnm(02)/'UER',19,23,155,14/
	data rt(03),ltd(03),ltm(03),lnd(03),lnm(03)/'KOA',19,20,155,15/
	data rt(04),ltd(04),ltm(04),lnd(04),lnm(04)/'MER',19,23,155,07/
	data rt(05),ltd(05),ltm(05),lnd(05),lnm(05)/'LER',19,28,154,54/
	data rt(06),ltd(06),ltm(06),lnd(06),lnm(06)/'SWR',19,21,155,20/
	data rt(07),ltd(07),ltm(07),lnd(07),lnm(07)/'SFL',19,21,155,01/
	data rt(08),ltd(08),ltm(08),lnd(08),lnm(08)/'KAO',19,26,155,24/
	data rt(09),ltd(09),ltm(09),lnd(09),lnm(09)/'HLE',19,14,155,30/
	data rt(10),ltd(10),ltm(10),lnd(10),lnm(10)/'MNE',19,32,155,28/
	data rt(11),ltd(11),ltm(11),lnd(11),lnm(11)/'GLN',19,30,155,11/
	data rt(12),ltd(12),ltm(12),lnd(12),lnm(12)/'SF1',19,14,155,21/
	data rt(13),ltd(13),ltm(13),lnd(13),lnm(13)/'SF2',19,19,155,13/
	data rt(14),ltd(14),ltm(14),lnd(14),lnm(14)/'SF3',19,22,155,01/
	data rt(15),ltd(15),ltm(15),lnd(15),lnm(15)/'SF4',19,24,154,58/
	data rt(16),ltd(16),ltm(16),lnd(16),lnm(16)/'KON',19,30,155,54/
	data rt(17),ltd(17),ltm(17),lnd(17),lnm(17)/'MWF',19,31,155,39/
	data rt(18),ltd(18),ltm(18),lnd(18),lnm(18)/'HUA',19,43,156,05/
	data rt(19),ltd(19),ltm(19),lnd(19),lnm(19)/'OHU',19,56,156,23/
	data rt(20),ltd(20),ltm(20),lnd(20),lnm(20)/'KOH',20,00,155,48/
	data rt(21),ltd(21),ltm(21),lnd(21),lnm(21)/'KEA',19,57,155,20/
	data rt(22),ltd(22),ltm(22),lnd(22),lnm(22)/'SAD',19,39,155,25/
	data rt(23),ltd(23),ltm(23),lnd(23),lnm(23)/'HIL',19,38,155,07/
	data rt(24),ltd(24),ltm(24),lnd(24),lnm(24)/'SFO',19,13,155,05/
	data rt(25),ltd(25),ltm(25),lnd(25),lnm(25)/'LOI',18,55,155,16/
	data rt(26),ltd(26),ltm(26),lnd(26),lnm(26)/'MIL',19,06,165,50/
	data rt(27),ltd(27),ltm(27),lnd(27),lnm(27)/'OKO',19,24,156,20/
	data rt(28),ltd(28),ltm(28),lnd(28),lnm(28)/'ALE',20,22,156,12/
	data rt(29),ltd(29),ltm(29),lnd(29),lnm(29)/'MAE',20,48,155,33/
	data rt(30),ltd(30),ltm(30),lnd(30),lnm(30)/'MAU',20,42,156,00/
	data rt(31),ltd(31),ltm(31),lnd(31),lnm(31)/'MOL',21,10,156,55/
	data rt(32),ltd(32),ltm(32),lnd(32),lnm(32)/'OAH',21,20,157,50/
	data rt(33),ltd(33),ltm(33),lnd(33),lnm(33)/'DEP',19,21,155,17/
	data rt(34),ltd(34),ltm(34),lnd(34),lnm(34)/'DLS',19,12,155,26/
	data rt(35),ltd(35),ltm(35),lnd(35),lnm(35)/'DLO',18,56,155,20/
	data rt(36),ltd(36),ltm(36),lnd(36),lnm(36)/'DER',19,19,155,03/
	data rt(37),ltd(37),ltm(37),lnd(37),lnm(37)/'DLE',19,24,154,50/
	data rt(38),ltd(38),ltm(38),lnd(38),lnm(38)/'DHI',19,52,155,08/
	data rt(39),ltd(39),ltm(39),lnd(39),lnm(39)/'DKE',19,55,155,30/
	data rt(40),ltd(40),ltm(40),lnd(40),lnm(40)/'DKO',19,35,156,00/
	data rt(41),ltd(41),ltm(41),lnd(41),lnm(41)/'DML',19,27,155,30/
	data rt(42),ltd(42),ltm(42),lnd(42),lnm(42)/'MSW',19,20,155,40/
	data rt(43),ltd(43),ltm(43),lnd(43),lnm(43)/'MOK',19,28,155,35/
	data rt(44),ltd(44),ltm(44),lnd(44),lnm(44)/'MNF',19,39,155,25/
	data rt(45),ltd(45),ltm(45),lnd(45),lnm(45)/'INT',19,24,155,16/
	data rt(46),ltd(46),ltm(46),lnd(46),lnm(46)/'MKO',20,19,155,15/

	t=0.
	tlast=-1.D20

	iforo=jask('Format: 1=Hypo71 2=H71-2000 3=HI 4=HI-2000',1)
	call iofl
	call askc ('Error output file',erfl)
	call openw (4,erfl,'f',ios,'s')
	call askc ('Comment output file',cmtfl)
	call openw (7,cmtfl,'f',ios,'s')
	write (7,*) 'Lines interpreted as comments, not eqs:'

c--get input format for the assignment of data to column positions
	write (6,1212) 
1212	format ('format 1: 1933-1959 25 cols'/
	2       'format 2: 1903-1921 22 cols'/
	3       'format 3: 1823-1903 15 cols'/
	4       'format 4: 1823-1903 11 cols (not used)'/
	5       'format 5: 1921-1932 23 cols'/
	6       'format 6: 1959-1963 20 cols')
	iform=jask('Input format',1)

	lwarn=lask('Output warning type errors',.false.)
	lmult=.false.
	lfull=lask('Output parsed fields for error listing',.false.)
	lclean=lask('preclean punctuation chars from pref mag',.false.)
	agcut=askr('Minimum mag for sum output',0.)

c--set parameters according to format type
	if (iform.eq.1) then
	  nfield=25
	else if (iform.eq.2) then
	  nfield=22
	else if (iform.eq.3) then
	  nfield=15
	else if (iform.eq.4) then
	  nfield=11
	else if (iform.eq.5) then
	  nfield=23
	else if (iform.eq.6) then
	  nfield=20
	end if

c--read column titles (first record)
	read (2,'(q,a)',err=18,end=90) ll,line
	call parse (',',line,600,nfield,title,len,nfound,icom,nfield)

	goto 20

18	write (4,1002) line(1:ll)
1002	format ('*** Bad line (unreadable):'/a)
	if (lfull) goto 70

c--read data lines
20	read (2,'(q,a)',err=18,end=90) ll,line
c--skip blank lines
	if (line(1:12).eq.'           ') then
	  write (4,*) '*** Blank line?:',line(1:ll)
	  goto 20
	end if
	star=' '

c--break line into fields
	call parse (',',line,600,nfield,field,len,nfound,icom,nfield)
	if (nfound.lt.nfield) then
	  write (4,1101) nfound, line(1:ll)
1101	  format('--- Only',i3,' fields found, pad with blank fields:'/a)
	end if

c--set fields according to format type
c--1933-1959
	if (iform.eq.1) then
c	  lendatf=len(1)
	  fdate=field(1)
	  lentimf=len(2)
	  ftime=field(2)
	  lenlatd=len(3)
	  flatd=field(3)
	  lenlatm=len(4)
	  flatm=field(4)
	  lenlond=len(5)
	  flond=field(5)
	  lenlonm=len(6)
	  flonm=field(6)
	  lenreg=len(7)
	  freg=field(7)
	  lendep=len(9)
	  fdep=field(9)
	  lenclass=len(13)
	  lenpmag=len(21)
	  fpmag=field(21)
	  lenpmags=len(22)
	  fpmags=field(22)
	  lenint=len(23)
	  cint=field(23)

c--1903-1921
	else if (iform.eq.2) then
c	  lendatf=len(1)
	  fdate=field(1)
	  lentimf=len(2)
	  ftime=field(2)
	  lenlatd=len(3)
	  flatd=field(3)
	  lenlatm=len(4)
	  flatm=field(4)
	  lenlond=len(5)
	  flond=field(5)
	  lenlonm=len(6)
	  flonm=field(6)
	  lenreg=len(7)
	  freg=field(7)
	  lendep=len(9)
	  fdep=field(9)
	  lenclass=len(13)
	  lenpmag=len(18)
	  fpmag=field(18)
	  lenpmags=len(19)
	  fpmags=field(19)
	  lenint=len(20)
	  cint=field(20)
	  
c--1823-1903 15 cols
	else if (iform.eq.3) then
c	  lendatf=len(1)
	  fdate=field(1)
	  lentimf=len(2)
	  ftime=field(2)
	  lenlatd=len(3)
	  flatd=field(3)
	  lenlatm=len(4)
	  flatm=field(4)
	  lenlond=len(5)
	  flond=field(5)
	  lenlonm=len(6)
	  flonm=field(6)
	  lenreg=len(7)
	  freg=field(7)
	  lendep=len(8)
	  fdep=field(8)
	  lenpmag=len(11)
	  fpmag=field(11)
	  lenpmags=len(12)
	  fpmags=field(12)
	  lenint=len(13)
	  cint=field(13)

c--1823-1903 11 cols
	else if (iform.eq.4) then
c	  lendatf=len(1)
	  fdate=field(1)
	  lentimf=len(2)
	  ftime=field(2)
	  lenreg=len(3)
	  freg=field(3)
	  lendep=len(4)
	  fdep=field(4)
	  lenpmag=len(7)
	  fpmag=field(7)
	  lenpmags=len(8)
	  fpmags=field(8)
	  lenint=len(9)
	  cint=field(9)

c--1921-1932
	else if (iform.eq.5) then
c	  lendatf=len(1)
	  fdate=field(1)
	  lentimf=len(2)
	  ftime=field(2)
	  lenlatd=len(3)
	  flatd=field(3)
	  lenlatm=len(4)
	  flatm=field(4)
	  lenlond=len(5)
	  flond=field(5)
	  lenlonm=len(6)
	  flonm=field(6)
	  lenreg=len(7)
	  freg=field(7)
	  lendep=len(9)
	  fdep=field(9)
	  lenclass=len(13)
	  lenpmag=len(19)
	  fpmag=field(19)
	  lenpmags=len(20)
	  fpmags=field(20)
	  lenint=len(21)
	  cint=field(21)

c--1959-1963
	else if (iform.eq.6) then
c	  lendatf=len(1)
	  fdate=field(1)
	  lentimf=len(2)
	  ftime=field(2)
	  lenlatd=len(3)
	  flatd=field(3)
	  lenlatm=len(4)
	  flatm=field(4)
	  lenlond=len(5)
	  flond=field(5)
	  lenlonm=len(6)
	  flonm=field(6)
	  lenreg=len(7)
	  freg=field(7)
	  lendep=len(8)
	  fdep=field(8)
	  lenclass=0
	  lenpmag=len(16)
	  fpmag=field(16)
	  lenpmags=len(17)
	  fpmags=field(17)
	  lenint=len(18)
	  cint=field(18)
	end if

c***************** screen out non-earthquake lines ********************
c--skip lines with no intensity or magnitude as these are comment lines
	if (lenpmag.eq.0 .and. lenint.eq.0 .and. lenclass.eq.0)
	2 then
c	  if (lwarn) then
c	    write (4,*) '--- No mag, intensity or class, so skip this entry'
c	    write (4,*) line(1:ll)
c	  end if
	  goto 80
	end if

c--skip lines with dittos as these are continuation lines
	if (freg.eq.'do' .or. fpmag.eq.'do') goto 20
	
c--skip Halemaumau rockfalls
	if (freg.eq.'hm rockfall') goto 20
c*******************************************************************

c--check date for bad characters
	if (index(fdate,'-').gt.0) then
	  write (4,*) '*** Bad date (has bad character): ',line(1:ll)
	  goto 20
	end if

c--parse date (M/D/Y in, yymmdd out)
	call parse ('/',fdate,90,3,cdate,lendate,nfound,icom,3)
	if (nfound.ne.3) then
	  write (4,*) '*** Bad date (need 3 parts): ',line(1:ll)
	  goto 20
	end if

	do i=1,3
	  read (cdate(i)(1:lendate(i)),*,iostat=ios) idate(i)
	  if (ios.gt.0) then
	    write (4,*) '*** Bad date (unreadable): ',line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	end do

c--trim year to 2 digits, but save 4-digit date as iyear
	if (idate(3).lt.100) then
	  iyear=1900+idate(3)
	else
	  iyear=idate(3)
	  kcent=idate(3)/100
	  idate(3)=idate(3) -kcent*100
	end if

c--extract repeat number from comment field (#25)
c  locate string "eqs; XX events" and grab XX as a number
c	n=1
c	ieqs=index(field(25),'eqs;')
c	if (ieqs.gt.0) then
c	  c5=field(25)(ieqs+4:ieqs+8)
c	  do j=1,5
c	    if (c5(j:j).eq.'e') c5(j:j)=' '
c	    if (c5(j:j).eq.'v') c5(j:j)=' '
c	  end do
c
c	  read (c5,*,iostat=ios) n
c	  if (ios.gt.0) then
c	    write (4,*) '*** Bad repeat number: '
c	    write (4,*) line(1:ll)
c	    if (lfull) goto 70
c	    goto 20
c	  end if
c	  if (lmult) write (6,1088) n,field(1),field(2),field(7),
c	2 field(13),field(21),field(14)
c1088	  format ('Repeat event',i4,' times: ',3a10,1x,a5,1x,a5,
c	2 ' (',a4,')')
c	end if

c--parse time (H:M:S in, hhmmss out)
	assumed=.false.

c--correct a real earthquake that has no time
	if (lentimf.eq.0) then
c--do not print warning in earlier catalog since no time is so common
	  if (iform.ne.3) then
	    write (4,*) '%%% No time (assume 12h 0m): '
	    write (4,*) line(1:ll)
	  end if
	  assumed=.true.
	  lentimf=5
	  ftime='12:00'
	end if

c	if (ftime.eq.'night' .or. ftime.eq.'early am') then
c	  ftime='1:00'
c	  lentimf=4
c	  assumed=.true.
c	end if
	
	call parse (':',ftime,90,3,ctime,lentime,nfound,icom,3)

	if (nfound.eq.2) then
	  ctime(3)='00'
	  lentime(3)=2

	else if (nfound.lt.2 .or. nfound.gt.3) then
	  if (ieqs.eq.0 .and. lwarn) then
	    write (4,*) '--- Bad time (assume 12h 0m): '
	    write (4,*) line(1:ll)
	  end if
	  assumed=.true.
	  ctime(1)='12'
	  ctime(2)='00'
	  ctime(3)='00'
	  lentime(1)=2
	  lentime(2)=2
	  lentime(3)=2
	end if

	do i=1,3
	  read (ctime(i)(1:lentime(i)),*,iostat=ios) itime(i)
	  if (ios.gt.0) then
	    write (4,*) '*** Bad time (unreadable): ',line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	end do

c--check for chron order, but not multiple events or events with assumed time
	if (ieqsl.eq.0 .and. ieqs.eq.0 .and. .not.assumed) then
	  t=dayjl(iyear,idate(1),idate(2))
	2 +(itime(1) +(itime(2) +itime(3)/60.)/60.)/24.D0
	  if (t.lt.tlast) then
	    write (4,*) '%%% Events out of chron order:'
	    write (4,*) llast(1:ll)
	    write (4,*) line(1:ll)
	  end if
	  llast=line
	  tlast=t
	  ieqsl=ieqs
	end if

c--lat & lon & preferred depth
	latd=0.
	if (lenlatd.gt.0) then
	  read (flatd,*,iostat=ios) latd
	  if (ios.gt.0) then
	    write (4,*) '*** Bad lat (d) (unreadable):',line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	end if
	ilatd=nint(latd)

	latm=0.
	if (lenlatm.gt.0) then
	  read (flatm,*,iostat=ios) latm
	  if (ios.gt.0) then
	    write (4,*) '*** Bad lat (m) (unreadable):',line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	end if
	ilatm=nint(latm*100.)

	lond=0.
	if (lenlond.gt.0) then
	  read (flond,*,iostat=ios) lond
	  if (ios.gt.0) then
	    write (4,*) '*** Bad lon (d) (unreadable):',line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	end if
	ilond=nint(lond)

	lonm=0.
	if (lenlonm.gt.0) then
	  read (flonm,*,iostat=ios) lonm
	  if (ios.gt.0) then
	    write (4,*) '*** Bad lon (m) (unreadable):',line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	end if
	ilonm=nint(lonm*100.)
	
c--check for lat/lon out of range
	x=lond+lonm/60.
	y=latd+latm/60.
	if (x.ne.0. .and. y.ne.0.) then
	  if (y.lt.12. .or. y.gt.28. .or. x.lt.149. .or. x.gt.160.) then
	    write (4,*) '*** Bad lat or lon:'
	    write (4,*) line(1:ll)
	  end if
	end if

	z=0.
	if (lendep.gt.0) then
	  read (fdep,*,iostat=ios) z
	  if (ios.gt.0) then
	    write (4,*) '*** Bad depth (unreadable):',line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	end if
	iz=z*100.

c--find 3-letter region name for region by looking for string within region name
	region=freg
	regn3='   '

c--convert to lower case
c	call downstr (region,25)

c--test for & flag question marks.
	cquest=" "
	do i=1,25
	  if (region(i:i).eq.'?') then
	    region(i:i)=' '
	    cquest="?"
	  end if
	end do

c--warn about missing region name
	if (region.eq.'     ') then
	  if (lwarn) write (4,1060) line(1:ll)
1060	  format (' --- No region for event, leave blank:'/1x,a)
	  goto 25
	end if

c--if region is unknown, leave field blank and keep 0 lat & lon
	if (region.eq.'unknown') then
	  star='X'
	  regn3='KIL'
	  goto 28
	end if

c--search for region name exactly
	do i=1,nreg
	  if (region .eq. reg(i)) then
	    regn3=reg3(i)
	    goto 25
	  end if
	end do

	write (4,*) '%%% Found unknown region name (leave blank): ',region
	write (4,*) line(1:ll)

c--insert lat/lon of region "seismic centroid" if it is not specified
25	if (ilatd.eq.0 .and. ilond.eq.0) then
	  do i=1,lreg
	    if (regn3 .eq. rt(i)) then
	      ilatd=ltd(i)
	      ilatm=ltm(i)*100
	      latm=ltm(i)
	      ilond=lnd(i)
	      ilonm=lnm(i)*100
	      lonm=lnm(i)
	      star='*'
	      goto 28
	    end if
	  end do
c--flag with X all events without a definte region
	  star='X'
	end if

c--preferred magnitude
28	pmag=0.

c--blank out remark characters
c	ldrop=.false.
c	do i=1,len(22)
c	  c1=field(22)(i:i)
c	  if(c1.eq.'(' .or. c1.eq.')' .or. c1.eq.'~' .or. c1.eq.'+' 
c	2 .or. c1.eq.'-' .or. c1.eq.'=' .or. c1.eq.'>') field(21)(i:i)=' '
c
c--reduce mag by 0.3 if < symbol used
c	  if (c1.eq.'<') then
c	    field(21)(i:i)=' '
c	    ldrop=.true.
c	  end if
c	end do

c--flag events with mag but no source
	if (lenpmag.gt.0 .and. lenpmags.eq.0) then
	  write (4,*) '%%% Magnitude but no mag source:'
	  write (4,*) line(1:ll)
	end if

c--flag events with mag source but no mag
	if (lenpmag.eq.0 .and. lenpmags.gt.0) then
	  write (4,*) '%%% Magnitude source but no magnitude:'
	  write (4,*) line(1:ll)
	end if

c--optionally clean bad characters from preferred magnitude
	if (lclean .and. lenpmag.gt.0) then
	  do i=1,lenpmag
	    if (fpmag(i:i).eq.'?') fpmag(i:i)=' '
	    if (fpmag(i:i).eq.'(') fpmag(i:i)=' '
	    if (fpmag(i:i).eq.')') fpmag(i:i)=' '
	    if (fpmag(i:i).eq.'~') fpmag(i:i)=' '
	    if (fpmag(i:i).eq.'+') fpmag(i:i)=' '
c	    if (fpmag(i:i).eq.'-') fpmag(i:i)=' '
	    if (fpmag(i:i).eq.'>') fpmag(i:i)=' '
	    if (fpmag(i:i).eq.'=') fpmag(i:i)=' '
	  end do
	end if

c--get preferred magnitude
	if (lenpmag.gt.0) then
	
	  if (index(fpmag(1:lenpmag),'?').gt.0 .or.
	2   index(fpmag(1:lenpmag),'(').gt.0 .or.
	2   index(fpmag(1:lenpmag),')').gt.0 .or.
	2   index(fpmag(1:lenpmag),'~').gt.0 .or.
	2   index(fpmag(1:lenpmag),'+').gt.0 .or.
c	2   index(fpmag(1:lenpmag),'-').gt.0 .or.
	2   index(fpmag(1:lenpmag),'>').gt.0 .or.
	2   index(fpmag(1:lenpmag),'<').gt.0 .or.
	2   index(fpmag(1:lenpmag),'=').gt.0) then
	
	    write (4,*) '*** Bad mag (may be unreadable):'
	    write (4,*) line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
	  
	  read (fpmag,*,iostat=ios) pmag
	  if (ios.gt.0) then
	    write (4,*) '*** Bad mag (unreadable):'
	    write (4,*) line(1:ll)
	    if (lfull) goto 70
	    goto 20
	  end if
c	  if (ldrop) pmag=pmag-0.3
	end if

c--get preferred mag as nomogram mag for cases in 1929 where the "pref mag"
c  is really the moment sum magnitude
c	if (len(14).gt.0) then
c	  if (field(23)(1:29) .eq. 'nomogram magnitude multiplied') then
c	    read (field(14),*,iostat=ios) pmag
c	    if (ios.gt.0) then
c	      write (4,*) '*** Bad mag (unreadable):',line(1:ll)
c	      if (lfull) goto 70
c	      goto 20
c	    end if
c	  end if
c	end if

	ipmag=nint(pmag*100.)

c--skip small events
	if (pmag.lt.agcut) goto 20

c--find preferred magnitude type
	magtyp=fpmags
c--convert to lower case
c	call downstr (magtyp,4)

	do i=1,nmtyp
	  if ( magtyp(1:ilenty(i)) .eq. mtyp(i)(1:ilenty(i))) then
	    pmtyp=mcode(i)
	    goto 30
	  end if
	end do

	pmtyp=' '
	if (magtyp.eq.'     ') goto 30

	write (4,*) '%%% Found unknown magnitude type (leave blank): ',
	2 magtyp
	write (4,*) line(1:ll)
30	continue

c--decode maximum intensity
c--search possible characters, assuming preferred intensity comes first
c  start with longest (exclusive) strings. ignore intensity I (not felt)
	int=0
	if (lenint.eq.0) goto 40
	
c--strip leading " in case field has an imbedded comma	
	if (cint(1:1).eq.'"') cint=cint(2:10)
	
	if (cint(1:4).eq.'felt') then
	  int=-1
	  goto 40
	end if
	if (cint(1:3).eq.'III') then
	  int=3
	  goto 40
	end if
	if (cint(1:2).eq.'II') then
	  int=2
	  goto 40
	end if

	if (cint(1:2).eq.'IX') then
	  int=9
	  goto 40
	end if
	if (cint(1:2).eq.'IV') then
	  int=4
	  goto 40
	end if

	if (cint(1:3).eq.'XII') then
	  int=12
	  goto 40
	end if
	if (cint(1:2).eq.'XI') then
	  int=11
	  goto 40
	end if
	if (cint(1:1).eq.'X') then
	  int=10
	  goto 40
	end if

c--Williamson descriptions
	if (cint(1:3).eq.'VVH') then
	  int=7
	  goto 40
	end if
	if (cint(1:2).eq.'VH') then
	  int=7
	  goto 40
	end if
	if (cint(1:2).eq.'VL') then
	  int=-1
	  goto 40
	end if
	if (cint(1:1).eq.'L') then
	  int=-1
	  goto 40
	end if
	if (cint(1:1).eq.'M') then
	  int=-1
	  goto 40
	end if
	if (cint(1:1).eq.'H') then
	  int=-1
	  goto 40
	end if
	if (cint(1:2).eq.'MH') then
	  int=-1
	  goto 40
	end if

	if (cint(1:4).eq.'VIII') then
	  int=8
	  goto 40
	end if
	if (cint(1:3).eq.'VII') then
	  int=7
	  goto 40
	end if
	if (cint(1:2).eq.'VI') then
	  int=6
	  goto 40
	end if
	if (cint(1:1).eq.'V') then
	  int=5
	  goto 40
	end if

c--decode numerical intensities
	if (cint(2:2).eq.'.') then
	  read (cint(1:3),'(f3.1)',err=38) xint
	  int=nint(xint)
	  goto 40
	end if
	
c--ignore these intensities
	if (cint(1:3).eq.'I R') then
	  int=0
	  goto 40
	end if

c--should have found a valid intensity, if not report error
38	write (4,*) '%%% Found bad intensity (leave blank): ',
	2 cint
	write (4,*) line(1:ll)
	
c--make intensity code
40	if (int.eq.-1) then
	  cint1='F'
	else if (int.eq.0) then
	  cint1=' '
	else if (int.eq.10) then
	  cint1='A'
	else if (int.eq.11) then
	  cint1='B'
	else if (int.eq.12) then
	  cint1='C'
	else
	  write (cint1,'(i1)') int
	end if

c--flag events with no pref mag, but another mag or intensity
c  determine this by totalling the lengths of the mag fields
	if (lenpmag.eq.0) then
	  itotlen=0
	  if (iform.eq.1) then		!33-59
	    do i=14,19
	      itotlen=itotlen+len(i)
	    end do
	  else if (iform.eq.2) then	!03-21
c--a limiting mag (<) is a reason for not using it as preferred
	    do i=14,16
	      if (field(15)(1:1).ne.'<') itotlen=itotlen+len(i)
	    end do
	  else if (iform.eq.5) then	!21-32
	    do i=14,17
	      itotlen=itotlen+len(i)
	    end do
	  else if (iform.eq.6) then	!59-63
	    do i=9,14
	      itotlen=itotlen+len(i)
	    end do
	  end if
	  
	  if (itotlen.gt.0) then
c--we have a mag but no pref mag
	    write (4,*) '%%% Should have a pref mag from other mags:'
	    write (4,*) line(1:ll)
	    goto 666
	  end if
	  
c--test to see if we should have gotten an intensity mag
	  if (int.gt.3) then
c--we have a large intensity but no pref mag
	    write (4,*) '%%% Should have a pref mag from max intensity:'
	    write (4,*) line(1:ll)
	  end if

666	  continue
	end if

c--write output record
c--write only 1 record if multiples are not wanted
	if (.not.lmult) n=1
	icount=icount+1
	do i=1,n
	
	  if (iforo.eq.1) then
c--hypo 71 format
	    write (3,1005) idate(3),idate(1),idate(2), itime,
	2   ilatd,latm, ilond,lonm, z,iyear, regn3,star,cquest,cint1,
	3   pmtyp,pmag, cint1
1005	    format (3i2.2, 1x, 2i2.2, i3,'.',2x, 
	2   i3,f6.2, i4,f6.2, f7.2, t54,i4, t94,a3,t78,3a1,
	3   t45,a1,f5.2)

	  else if (iforo.eq.2) then
c--hypo 71-2000 format
	    write (3,1006) iyear,idate(1),idate(2), itime,
	2   ilatd,latm, ilond,lonm, z, regn3,star,cquest,cint1,
	3   pmtyp,pmag
1006	    format (i4,2i2.2, 1x, 2i2.2, i3,'.',2x, 
	2   i3,f6.2, i4,f6.2, f7.2, t96,a3,t80,3a1,
	3   t47,a1,f5.2)
	
	  else if (iforo.eq.3) then
c--hypoinverse
	    write (3,1004) idate(3),idate(1),idate(2), itime,
	2   ilatd,ilatm, ilond,ilonm, iz,iyear, regn3,star,cquest,
	3   cint1, pmtyp,ipmag
1004	    format (6i2.2,2x, 
	2   i2,i5,i3,2i5, t46,i4, t70,a3,t77,2a1,
	3   t107,a1, t139,a1,i3)
	
	  else if (iforo.eq.4) then
c--hypoinverse-2000
	    write (3,1007) iyear,idate(1),idate(2), itime,
	2   ilatd,ilatm, ilond,ilonm, iz, regn3,star,cquest,
	3   cint1, pmtyp,ipmag
1007	    format (i4,5i2.2,2x, 
	2   i2,i5,i3,2i5, t74,a3,t81,2a1,
	3   t115,a1, t147,a1,i3)

	  end if
	end do

c--write full list of first event
	if (icount.lt.2) then
c	  write (6,*) 'count=',icount
	  if (ieqs.gt.0) write (6,*) 'Repeat',n,' times'
	  do i=1,nfield
	    write (6,1001) i,title(i),len(i),field(i)(1:len(i))
1001	    format (i2,1x,a20,i4,1x,a)
	  end do
	end if

c--write full list of fields for error events or those without a time
	if (.not.assumed .or. .not.lfull) goto 20
70	do i=1,nfield
	  write (4,1001) i,title(i),len(i),field(i)(1:len(i))
	end do
	goto 20

c--write all the lines interpreted as comments
80	write (7,*) line(1:ll)
	goto 20

90	stop
	end
c---------------------------------------------------------------
	subroutine parse (delim,line,lenrec,nf,field,len,nfound,
	2 icom,nfield)

c	call parse (',',line,600,nfield,field,len,nfound,icom,nfield)
c	call parse (':',ftime,90,3,ctime,lentime,nfound,icom,3)

c--parses (comma) separated fields, allowing for quoted strings enclosing commas
	logical lquote

c--input
	character delim*1	!delimeter character
	character line*(*)	!input string
	integer lenrec		!the length of line*(*)
	integer nf		!number of fields to parse from input
	integer nfield		!number of fields to dimension
c--output
	character field(1)*(*)	!parsed ascii fields
	dimension len(1)		!length of each field
	integer nfound			!number of fields found
	dimension icom(1)		!column numbers of found delimiters

	if (nf.lt.1 .or. nf.gt.nfield) then
	  write (6,*) '*** Bad value for number of fields',nf
	  stop
	end if
	do i=1,nf
	  field(i)=' '
	  len(i)=0
	end do

c--------------
c--find delimeters (commas), skipping ones inside quotes
	kf=0	!the found number of commas, kf+1= found number of fields
	lquote=.false.

c--loop over each column
	do ic=1,lenrec

c--test for quote
	  if (line(ic:ic).eq.'"') lquote=.not.lquote

c--test for delimiter, & save column if not in quote
	  if (line(ic:ic).eq.delim .and. .not.lquote) then
	    kf=kf+1
	    icom(kf)=ic
	    if (kf.ge.nf) goto 10	!we have found all the fields requested
	  end if
	end do

c--alert of missing fields
c	if (kf+1.lt.nf) then
c	  write (4,1001) kf+1, line
c1001	  format('*** Only',i3,' fields found, pad with blank fields:'/a)
cc	  do i=kf+2,nf
cc	    field(i)=' '
cc	  end do
c	end if

c--supply position of final field terminator (comma) if it is missing
c	if (kf+1.eq.nf) then
	if (kf+1.le.nf) then
	  do ic=lenrec,1,-1
	    if (line(ic:ic).ne.' ') then
	      icom(kf+1)=ic+1
	      goto 10
	    end if
	  end do
	end if

c-------------------
c--set the first field length & field
10	len(1)=icom(1)-1
	field(1)=line(1:icom(1)-1)

c--set the remaining field lengths & fields
	do i=2,kf+1
	  len(i)= icom(i)-icom(i-1)-1
	  field(i)= line(icom(i-1)+1: icom(i)-1)
	end do

c--eliminate any leading tabs
	do i=1,kf+1
20	  continue
	  if (len(i).gt.0) then
	    if (ichar(field(i)(1:1)).eq.9) then
	      field(i)=field(i)(2:len(i))
	      len(i)=len(i)-1
	      goto 20
	    end if
	  end if
	end do

	nfound=kf+1
	return
	end
c-------------------------------------
      SUBROUTINE ASKC (PROMPT, STRING)

C  ASKC PROMPTS THEN READS A CHARACTER STRING FROM THE TERMINAL.
C  THE ORIGINAL VALUE IS UNCHANGED BY A CR RESPONSE.

      CHARACTER  PROMPT*(*)            ! PROMPT STRING
      CHARACTER  STRING*(*)  ! CHARACTER RESPONSE, OR ORIGINAL STRING ON CR.
      CHARACTER  TEMP*80              ! SCRATCH
      INTEGER    LENG                 ! FUNCTION
      INTEGER    NCH                  ! NUMBER OF CHARACTERS
      INTEGER    OUNIT  ! LOGICAL UNIT FOR OUTPUT (0 FOR UNIX, 6 FOR VMS)
      PARAMETER (OUNIT = 6)
C      PARAMETER (OUNIT = 0)

      NCH = LENG(STRING)
10    WRITE (OUNIT, 20) PROMPT
20    FORMAT (1X, A)
      IF (NCH .LT. 20) THEN
        WRITE (OUNIT, 30) STRING(1:NCH)
30      FORMAT (' [CR = ', A, ']? ', $)
      ELSE
        WRITE (OUNIT, 40) STRING(1:NCH)
40      FORMAT (' [CR = ', A, ']?')
      END IF
      READ (5, '(A)', ERR = 10, END = 50) TEMP
      IF (LENG(TEMP) .GT. 0) STRING = TEMP
50    RETURN
      END

      FUNCTION DAYJL(JY,JM,JD)
C--RETURNS THE PERPETUAL JULIAN DAY RELATIVE TO JAN 1, 1960
C--FOR YEARS JY FROM 0 TO 99 (INCLUSIVE) IN THE 20TH CENTURY
C--OR YEARS JY LARGER THAN 1582.
C--THE JULIAN DAY ON JAN 1, 1960 AT 0H U.T. WAS 2436934.5,
C--BUT THIS FUNCTION RETURNS DAYJL (60,1,1) = 0.
      K=JY
      IF (K.LT.300) K=K+1900
      L=JM
      IF (L.GT.2) GOTO 10
      K=K-1
      L=L+12
10    A=365.25*(K-1960)
      I=.01*K
      B=30.6001*(L+1)
      DAYJL=AINT(A)+AINT(B)+(JD-I-48)+AINT(.25*I)
C--CORRECT DAY IF AINT TOOK THE INTEGER PART OF A NEGATIVE NO.
      IF (A.LT.0.) DAYJL=DAYJL-1.
      RETURN
      END
	SUBROUTINE IOFL
C--PROMPTS FOR AND OPENS AN INPUT (UNIT 2) AND OUTPUT (UNIT 3) FILE
C--NO CARRIAGE CONTROL CHARACTER IS EXPECTED ON OUTPUT.
	CHARACTER IFL*80
	WRITE (6,1000)
1000	FORMAT (' INPUT FILENAME? '$)
	READ (5,1001) IFL
1001	FORMAT (A)
	call openr (2,ifl,'f',ios)
	if (ios.ne.0) then
	  print *,'*** Error: cant open input file'
	  stop
	end if

	WRITE (6,1002)
1002	FORMAT (' OUTPUT FILENAME? '$)
	READ (5,1001) IFL
	call openw (3,ifl,'f',ios,'s')
	if (ios.ne.0) then
	  print *,'*** Error: cant open output file'
	  stop
	end if
	RETURN
	END
      SUBROUTINE OPENR (IUNIT,FIL,FOR,IOS)
C--OPEN A FILE FOR READING ON THE SUN OR THE VAX (SAME SUBROUTINE).
C--THE FILE MUST EXIST TO AVOID AN ERROR.

C--THE ARGUMENTS ARE:
C  IUNIT   UNIT NUMBER (INTEGER)
C  FIL     CHAR STRING CONTAINING FILENAME
C  FOR     CHAR STRING FOR THE FORM SPECIFIER:
C            'F' OR 'FORMATTED'   ASCII FILE TO READ FORMATTED
C            'U' OR 'UNFORMATTED' BINARY FILE TO READ UNFORMATTED
C  IOS     ERROR RETURN:
C            0    OPEN WAS OK
C            >0   AN ERROR OCCURRED

      CHARACTER FIL*(*), FOR*(*), FSTR*11
      INTEGER IUNIT,IOS

      FSTR='formatted'
      IF (FOR(1:1).EQ.'u' .OR. FOR(1:1).EQ.'U') FSTR='unformatted'

C--VAX VERSION
C      OPEN (IUNIT,FILE=FIL,FORM=FSTR,IOSTAT=IOS,STATUS='OLD',
C     2 BLANK='ZERO', SHARED, READONLY, RECL=256)

C--SUN & OS2 VERSION
      OPEN (IUNIT,FILE=FIL,FORM=FSTR,IOSTAT=IOS,STATUS='OLD',
     2 BLANK='ZERO')

      RETURN
      END
      SUBROUTINE OPENW (IUNIT,FIL,FOR,IOS,ACC)
C--OPEN A FILE FOR WRITING

C--THE ARGUMENTS ARE:
C  IUNIT   UNIT NUMBER (INTEGER)
C  FIL     CHAR STRING CONTAINING FILENAME
C  FOR     CHAR STRING FOR THE FORM SPECIFIER:
C            'F' OR 'FORMATTED'   ASCII FILE TO READ FORMATTED
C            'U' OR 'UNFORMATTED' BINARY FILE TO READ UNFORMATTED
C            'P' OR 'PRINT'       ASCII FILE TO WRITE WITH CARRIAGECONTROL
C                   CHARACTER
C  IOS     ERROR RETURN:
C             0    OPEN WAS OK
C             >0   AND ERROR OCCURRED
C  ACC     ACCESS SPECIFIER
C            'S' OR 'SEQUENTIAL'  NORMAL ACCESS, WRITE FROM BEGINNING OF FILE
C            'A' OR 'APPEND'      WRITE AT END OF FILE IF IT EXISTS

      CHARACTER FIL*(*), FOR*(*), ACC*(*), FSTR*12, ASTR*11, CC*9
      INTEGER IUNIT,IOS

      FSTR='formatted  '
      IF (FOR(1:1).EQ.'u' .or. FOR(1:1).EQ.'U') FSTR='unformatted  '
C--SUN & OS2
      IF (FOR(1:1).EQ.'p' .or. FOR(1:1).EQ.'P') FSTR='print  '
C--VAX
C      CC='list  '
C      IF (FOR(1:1).EQ.'p' .OR. FOR(1:1).EQ.'P') CC='FORTRAN  '

      ASTR='sequential  '
      IF (ACC(1:1).EQ.'a' .OR. ACC(1:1).EQ.'A') ASTR='append  '

C--SUN
      OPEN (IUNIT,FILE=FIL, FORM=FSTR, IOSTAT=IOS, STATUS='unknown',
     2 ACCESS=ASTR)

C--OS2
C      OPEN (IUNIT,FILE=FIL, FORM=FSTR, IOSTAT=IOS, STATUS='UNKNOWN',
C     2 ACCESS=ASTR)

C--VAX
C      OPEN (IUNIT,FILE=FIL, FORM=FSTR, IOSTAT=IOS, STATUS='NEW',
C     2 ACCESS=ASTR, CARRIAGECONTROL=CC, RECL=256)
      RETURN
      END
      REAL FUNCTION ASKR (PROMPT, DFLT)

C  ASKR PROMPTS THEN READS A REAL VALUE FROM THE TERMINAL.
C  THE DEFAULT VALUE IS RETURNED ON A CR RESPONSE.

      REAL  DFLT ! DEFAULT SUPPLIED ON CARRIAGE RETURN AND DISPLAYED IN PROMPT
      CHARACTER PROMPT*(*)         ! PROMPT STRING
      INTEGER   I                  ! LOOP INDEX
      INTEGER   J                  ! LOOP INDEX
      INTEGER   LENG               ! FUNCTION
      CHARACTER TEMP*20            ! SCRATCH
      INTEGER   OUNIT  ! LOGICAL UNIT FOR OUTPUT (0 FOR UNIX, 6 FOR VMS)

      PARAMETER (OUNIT = 6)

      WRITE (TEMP, 10) DFLT
10    FORMAT (G20.5)
      DO 20 I = 1, 20
        IF (TEMP(I:I) .NE. ' ') GOTO 30
20    CONTINUE
30    DO 40 J = 20, 1, -1
        IF (TEMP(J:J) .NE. ' ') GOTO 50
40    CONTINUE
50    WRITE (OUNIT, 60) PROMPT, TEMP(I:J)
60    FORMAT (1X, A, ' [cr = ', A, ']? ', $)
      READ (5, '(A)', ERR = 50, END = 70) TEMP
      IF (LENG(TEMP) .GT. 0) THEN
        READ (TEMP, *, ERR = 50) ASKR
      ELSE
        ASKR = DFLT
      END IF
70    RETURN
      END
      INTEGER FUNCTION JASK (PROMPT, IDFLT)
C
C  JASK PROMPTS THEN READS AN INTEGER VALUE FROM THE TERMINAL.
C  THE DEFAULT VALUE IS RETURNED ON A CR RESPONSE.
C  IDFLT IS DEFAULT SUPPLIED ON CARRIAGE RETURN AND DISPLAYED IN PROMPT

      INTEGER     IDFLT
      CHARACTER   PROMPT*(*)	! PROMPT STRING
      CHARACTER   TEMP*20	! SCRATCH
      INTEGER     I		! LOOP INDEX
      INTEGER     LENG		! FUNCTION
      INTEGER     OUNIT	! LOGICAL UNIT FOR OUTPUT (0 FOR UNIX, 6 FOR VMS)

      PARAMETER (OUNIT = 6)

      WRITE (TEMP, 10) IDFLT
10    FORMAT (I20)
      DO 20 I = 1, 20
        IF (TEMP(I:I) .NE. ' ') GOTO 30
20    CONTINUE
30    WRITE (OUNIT, 40) PROMPT, TEMP(I:20)
40    FORMAT (1X, A, ' [cr = ', A, ']? ', $)
      READ (5, '(A)', ERR = 30, END = 50) TEMP
      IF (LENG(TEMP) .GT. 0) THEN
        READ (TEMP, *, ERR = 30) JASK
      ELSE
        JASK = IDFLT
      END IF
50    RETURN
      END
      LOGICAL FUNCTION LASK (PROMPT,LDFLT)
C--LASK PROMPTS USING THE STRING "PROMPT", THEN READS A LOGICAL VALUE
C--FROM THE TERMINAL. THE DEFAULT VALUE LDFLT IS RETURNED ON A CR RESPONSE.
C      LASK= LOGICAL RESPONSE.
C      PROMPT= PROMPT STRING.

      CHARACTER PROMPT*(*), TEMP*20
      LOGICAL LDFLT
5     WRITE (6,1001) PROMPT,LDFLT
1001  FORMAT (1X,A,' [t or f, cr=',l1,']? ',$)

      READ (5,'(A)',ERR=5,END=9) TEMP
      IF (LENG(TEMP).GT.0) THEN
        READ (TEMP,*,ERR=5) LASK
      ELSE
        LASK=LDFLT
      END IF
9     RETURN
      END
      INTEGER FUNCTION LENG (STRING)
C
C THE NON-BLANK LENGTH OF STRING WHOSE PHYSICAL LENGTH IS MAXLEN
C (RETURNS THE POSITION OF THE LAST NON-BLANK CHARACTER)
C
      CHARACTER         STRING*(*)	! STRING
C
      INTEGER           I		! CHARACTER POSITION
      INTEGER           MAXLEN		! LENGTH OF STRING

      MAXLEN = LEN(STRING)
      DO 10 I = MAXLEN,1,-1
        IF (STRING(I:I) .NE. ' ') GOTO 20
10    CONTINUE
      I = 0
20    LENG = I
      RETURN
      END