c
c  Author:
c
c	Gerhard Lust
c	Geotechnisches Institut
c	Abt. Isotopengeophysik
c	Bundesversuchs- und Forschungsanstalt Arsenal
c	Faradaygasse 3
c	A-1030 Wien
c
c	Tel.: +43/222/782531/518
c	Datexp : PSI%023226191064::SYSTEM
c
c*********************************************************
c	There is no copyright attached to this program.
c	Use it at your own risk.
c
c	V 1.0- 001
c
c*********************************************************
c
c	Requires SYSNAM, SYSPRV, OPER and LOG_IO privileges
c
	program		setday
c
	implicit	integer*4 (a-z)
c
	character*11	ostern			! Tag an dem Ostersonntag ist
	character*11	feiertage_fix(30)	! Inputvariable fuer max. 30
c						! Feiertage (fixer Tag)
	character*11	feiertage_bew (30)	! Inputvariable fuer max. 30
c						! Feiertage (bewegliche Tage)
	character*11	spring,fall		! Herbst, bzw. Fruehlingsbeginn 
	character*80	log_name_fix(30)	! Bezeichnung fuer max. 30
c						! Feiertage (fixer Tag)
	character*80	log_name_bew(30)	! Bezeichnung fuer max. 30
c						! Feiertage (bewegliche Tage)
	character*80	record			! Input-Record
	character*23	heute			! Aktueller Tag
	character*23	test_tag		! Testvariable
	character*23	mez			! Beginn der MEZ (Mittel-
c						! europaischer Zeit
	character*23	mez_dst			! Beginn der MEZ-Sommerzeit
	character*4	one_day /'1 ::'/	! Tagesdifferenz
	character*5	one_hour/'0 1::'/	! Stundendifferenz
	character*10	table/'LNM$SYSTEM'/	! Table fuer Logical
	character*7	log_name/'HOLIDAY'/	! Logical Name
	character*80	log_text		! Text fuer Logical
	character*9	set_uaf_day		! SET DAY/ SECONDARY
c
	integer*4	wochentag		! Aktueller Wochentag
	integer*4	mez_day			! Beginn MEZ- Wochentag
	integer*4	mez_dst_day		! Beginn MEZ-Sommerzeit-
c						! Wochentag
	integer*4	diff(60)		! Bewegliche Feiertage binaer
c						! (max.30)
	integer*4	ostern_bin(2)		! Ostersonntag binaer
	integer*4	test_time(2)		! Testvariable
	integer*4	one_day_bin(2)		! Tagesdifferenz binaer
	integer*4	one_hour_bin(2)		! Stundendifferenz binaer
	integer*4	spring_bin(2)		! Fruehlingsbeginn binaer
	integer*4	fall_bin(2)		! Herbstbeginn binaer
	integer*4	start_spring(2)		! AST-Startzeit fuer MEZ-
c						! Sommerzeit
	integer*4	start_fall(2)		! AST-Startzeit fuer MEZ
	integer*4	morgen(2)		! Naechster Tag 00:00 Uhr binaer
	integer*4	record_len		! Input-Record-Laenge
	integer*4	morgen_flg/1/		! Flag fuer Timer-Queue
	integer*4	privmask(2)		! Prozess-Privilegien
	integer*4	first_character		! Kommentarzeile ?
c
	integer*2	m,n,j,a,b,c,d,e,os	! Variable fuer Gauss
	integer*2	len_fix(30)		! Laenge der Bezeichnung fuer
c						! max 30 Feiertage (fest)
	integer*2	len_bew(30)		! Laenge der Bezeichnung fuer
c						! max. 30 Feiertage (beweglich)
	integer*2	bew_count,fest_count	! Hilfsvariable
	integer*2	text_len		! Text-Laenge fuer Logical
c
	byte		art			! Art des Feiertages (fest
c						! oder beweglich)
	byte		art_time		! Beginn einer Zeitaenderung
c						! (Sommerzeit oder MEZ)
	byte		art_weekday		! Wochentag (Samstag oder
c						! Sonntag)
	byte		feiertg_flg		! Genaue Position des laufenden
c						! Feiertages (fest oder beweg-
c						! lich, je nach ART)
c
	byte		fix,bew,daylight,normal ! Parameter fuer ART, ART_TIME
	byte		samstag,sonntag		! und ART_WEEKDAY
c
	byte		start/0/		! Start-Flag
c
	include		'($prvdef)'
c
c*------------------------------------------------------------------------
c
	common/one_hour_bin/one_hour_bin
c
	external  springtime,falltime
c
c*------------------------------------------------------------------------
c	Flags fuer verschiedene Ereignisdaten
c
	parameter	(fix     = '1'x)	! fixer Feiertag
	parameter	(bew     = '2'x)	! beweglicher Feiertag 
	parameter	(samstag = '3'x) 	! Samstag
	parameter	(sonntag = '4'x)	! Sonntag
	parameter	(daylight= '5'x)	! Beginn MEZ-Sommerzeit
	parameter	(normal  = '6'x)	! Beginn MEZ
c
c*-----------------------------------------------------------------------
c
	spring		  = '23-MAR'		! Fruehlingsbeginn
	fall		  = '23-SEP'		! Herbstbeginn
c
c*-----------------------------------------------------------------------
c	Prozessnamen eintragen, Prozess-Privilegien festlegen
c
	stat = sys$setprn ('Set_Day')
	if (.not.stat) call lib$stop(%val(stat))
c
c	Alle Privilegien disablen
c
	privmask(1) = 'ffffffff'x
	privmask(2) = 'ffffffff'x
c
	stat = sys$setprv(%val(0),privmask,%val(1),)
	if (.not.stat) call lib$stop(%val(stat))
c
c	Genau definierte Privilegien enablen
c
	privmask(1) = prv$m_sysnam.or.prv$m_sysprv.or.prv$m_oper
	1.or.prv$m_log_io.or.prv$m_tmpmbx
	privmask(2) = 0
c
	stat = sys$setprv(%val(1),privmask,%val(1),)
	if (.not.stat) call lib$stop(%val(stat))
c
c*-----------------------------------------------------------------------
c	Eintages- bzw. Einstundendifferenz binaer ablegen
c
	stat = sys$bintim (one_day,one_day_bin)
	if (.not.stat) call lib$stop(%val(stat))
c
	stat = sys$bintim (one_hour,one_hour_bin)
	if (.not.stat) call lib$stop(%val(stat))
c
c*---------------------------------------------------------------------------
c*---------------------------------------------------------------------------
c	Aktuellen Tag einlesen
c
50	call lib$day_of_week (,wochentag)
	call lib$date_time (heute)
	read (heute(8:11),'(i)') j
c
c*-------------------------------------------------------------------------
c	Fuer dieses Jahr Herbstbeginn sowie Fruehlingsbeginn binaer ablegen.
c
	stat = sys$bintim (fall(:6),fall_bin)
	if (.not.stat) call lib$stop(%val(stat))
c
	stat = sys$bintim (spring(:6),spring_bin)
	if (.not.stat) call lib$stop(%val(stat))
c
c*-----------------------------------------------------------------------
c	Solange zum Herbstbeginn 1 Tag addieren -> bis naechster Sonntag
c
100	stat= lib$add_times (fall_bin,one_day_bin,fall_bin)
	if (.not.stat) call lib$stop(%val(stat))
c
	call lib$day_of_week (fall_bin,mez_day)
	if (mez_day.eq.7) then
		stat = sys$asctim (,mez,fall_bin,)
		if (.not.stat) call lib$stop(%val(stat))
c
	else
		goto 100
	end if
c
c*------------------------------------------------------------------------
c	Solange zum Fruehlingsbeginn 1 Tag addieren -> bis naechster Sonntag
c
200	stat= lib$add_times (spring_bin,one_day_bin,spring_bin)
	if (.not.stat) call lib$stop(%val(stat))
c
	call lib$day_of_week (spring_bin,mez_dst_day)
	if (mez_dst_day.eq.7) then
		stat = sys$asctim (,mez_dst,spring_bin,)
		if (.not.stat) call lib$stop(%val(stat))
c
	else
		goto 200
	end if
c
c*----------------------------------------------------------------------
c	Variable auf 0 stellen
c
300	fest_count = 0
	bew_count  = 0
c
	do i=0,29
		feiertage_fix(i+1) = ' '
		feiertage_bew(i+1) = ' '
		log_name_fix(i+1)  = ' '
		log_name_bew(i+1)  = ' '
		len_fix(i)	   = 0
		len_bew(i)	   = 0
		diff(i*2+1)        = 0
		diff(i*2+2)        = 0
	end do
c
	art                = 0
	art_time           = 0
	art_weekday        = 0
	feiertg_flg        = 0
	text_len           = 0
	ostern		   = ' '
	test_tag	   = ' '
	log_text   	   = ' '
c
c
c*-----------------------------------------------------------------------
c
c	Liste aller Feiertage aus Database einlesen
c
	open (unit=1,file='HOLIDAY$BASE',status='old',readonly,
	1 shared,iostat=stat)
c
400	read (1,'(q,a)',end=500) record_len,record
c
c	Kommentarzeile ??
c
	first_character = str$find_first_not_in_set (record,' ')
	if (record (first_character:first_character).eq.'!') goto 400
c
	if (record(:record_len).eq.'F') then
410		read (1,'(q,a)',end=510) record_len,record
c
c		Kommentarzeile ??
c
		first_character = str$find_first_not_in_set (record,' ')
		if (record (first_character:first_character).eq.'!') goto 410
c
c	Zur Ueberpruefung ob Database korrekte Daten enthaelt wird umgeformt
c
		stat = sys$bintim(record(:record_len),test_time)
		if (.not.stat) goto 510
c
		stat = sys$asctim(,test_tag,test_time,)
		if (.not.stat) goto 510
c
		feiertage_fix(fest_count+1) = test_tag(:6)
c
420		read (1,'(q,a)',end=510) record_len,record
c
c		Kommentarzeile ??
c
		first_character = str$find_first_not_in_set (record,' ')
		if (record (first_character:first_character).eq.'!') goto 420
c
		log_name_fix(fest_count+1) = record(:record_len)
		call str$trim(log_name_fix(fest_count+1),
	1	log_name_fix(fest_count+1),len_fix(fest_count+1))
		fest_count = fest_count + 1
c
	else if (record(:record_len).eq.'B') then
c
430		read (1,'(q,a)',end=510) record_len,record
c
c		Kommentarzeile ??
c
		first_character = str$find_first_not_in_set (record,' ')
		if (record (first_character:first_character).eq.'!') goto 430
c
		feiertage_bew(bew_count+1) = record(:record_len)
		if (index(record(:record_len),'-').ne.0) then
			record(1:) = record(2:record_len)
			record_len = record_len - 1
		end if
c
		stat = sys$bintim (record(:record_len)//' ::',
	1		diff(bew_count*2+1))
		if (.not.stat) goto 510
c
440		read (1,'(q,a)',end=510) record_len,record
c
c		Kommentarzeile ??
c
		first_character = str$find_first_not_in_set (record,' ')
		if (record (first_character:first_character).eq.'!') goto 440
c
		log_name_bew(bew_count+1) = record(:record_len)
		call str$trim(log_name_bew(bew_count+1),
	1		log_name_bew(bew_count+1),len_bew(bew_count+1))
c
		bew_count = bew_count + 1
	end if
c
	goto 400
c
500	close (1)
	goto 520
c
c*---------------------------------------------------------------------------
c
510	call request ('SETDAY: Unkorrekte DATABASE --> SETDAY gestoppt !')
	goto 700
c
c*---------------------------------------------------------------------------
c	Berechnung des Ostersonntages nach Regel von C.F.Gauss 
c	gueltig in den Jahren 1900-2099
c
520	m = 24
	n = 5
c
	a = j-((j/19)*19)
	b = j-((j/4)*4)
	c = j-((j/7)*7)
	d = (19*a+m)-(((19*a+m)/30)*30)
	e = (2*b+4*c+6*d+n)-(((2*b+4*c+6*d+n)/7)*7)
c
	if ((22+d+e).le.31) then
		os = 22+d+e
		encode (2,'(i2)',ostern(1:)) os
		ostern(3:6) = '-MAR'
	else
		os = d+e-9
		encode (2,'(i2)',ostern(1:)) os
		ostern(3:6) = '-APR'
	end if
c
c*-------------------------------------------------------------------
c	Die Ausnahmen von der Regel
c
	if (ostern(:6).eq.'26-APR') 
	1 ostern(:6) = '19-APR'
c
	if (ostern(:6).eq.'25-APR'.and.d.eq.28.and.e.eq.6
	1.and.a.gt.10)
	1 ostern(:6) = '18-APR'
c
c*---------------------------------------------------------------------
c	Ostersonntagsdatum binaer ablegen
c
	stat = sys$bintim (ostern(:6),ostern_bin)
	if (.not.stat) call lib$stop(%val(stat))
c
c*-----------------------------------------------------------------------
c	Suche ob aktueller Tag ein fester Feiertag ist
c
	do  i=1,30
		if (feiertage_fix(i).ne.' ') then
			if (heute(:6).eq.feiertage_fix(i)(:6)) then
				art = fix
				feiertg_flg = i
				goto 600
			end if
		end if
	end do
c
c*------------------------------------------------------------------
c	Suche ob aktueller Tag ein beweglicher Feiertag ist
c
	do i=0,29
		if (feiertage_bew(i+1).ne.' ') then
c
c		Wenn Tagesdifferenz 0, dann ist es der Ostersonntag
c
			if (diff(i*2+1).eq.0.and.diff(i*2+2).eq.0) then
				test_tag = ostern
			else if (index(feiertage_bew(i+1),'-').gt.0) then
					stat= lib$sub_times (ostern_bin,
	1					diff(i*2+1),test_time)
					if (.not.stat)
	1				call lib$stop(%val(stat))
c
					stat = sys$asctim
	1				(,test_tag,test_time,)
					if (.not.stat)
	1				call lib$stop(%val(stat))
c
			else if (index(feiertage_bew(i+1),'-').eq.0) then
					stat= lib$add_times (ostern_bin,
	1					diff(i*2+1),test_time)
					if (.not.stat)
	1				call lib$stop(%val(stat))
c
					stat = sys$asctim
	1				(,test_tag,test_time,)
					if (.not.stat)
	1				call lib$stop(%val(stat))
c
			end if
c
			if (heute(:6).eq.test_tag(:6)) then
				art = bew
				feiertg_flg = i+1
				goto 600
			end if
		end if
	end do
c
c*------------------------------------------------------------------------
c	Ist aktueller Tag ein Samstag, bzw. Sonntag ?
c
600	if (wochentag.eq.6) art_weekday = samstag
	if (wochentag.eq.7) art_weekday = sonntag
c
c*------------------------------------------------------------------------
c	Ist aktueller Tag Beginn der Sommerzeit, bzw. Normalzeit ?
c
	if (heute(:6).eq.mez(:6)) then
		stat = sys$bintim (heute (:11)//' 03:00',start_fall)
		if (.not.stat) call lib$stop(%val(stat))
c
		stat = sys$setimr (,start_fall,falltime,)
		if (.not.stat) call lib$stop(%val(stat))
c
		art_time   = normal
	end if
c
	if (heute(:6).eq.mez_dst(:6)) then
		stat = sys$bintim (heute(:11)//' 02:00',start_spring)
		if (.not.stat) call lib$stop(%val(stat))
c
		stat = sys$setimr (,start_spring,springtime,)
		if (.not.stat) call lib$stop(%val(stat))
c
		art_time = daylight
	end if
c
c*-------------------------------------------------------------------------
c	String fuer Logical zusammensetzen
c
	text_len = 1
	set_uaf_day = ' '
c
	if (art.eq.fix) then
		log_text(:len_fix(feiertg_flg)) =
	1	log_name_fix(feiertg_flg)(:len_fix(feiertg_flg))
		text_len = len_fix(feiertg_flg)
		set_uaf_day = 'SECONDARY'
	else if (art.eq.bew) then
		log_text(:len_bew(feiertg_flg)) =
	1	log_name_bew (feiertg_flg)(:len_bew(feiertg_flg))
		text_len = len_bew(feiertg_flg)
		set_uaf_day = 'SECONDARY'
c
	else if (art_weekday.eq.samstag) then
		log_text(text_len:) = 'Samstag'
		text_len = 7
		set_uaf_day = 'SECONDARY'
c
	else if (art_weekday.eq.sonntag) then
		log_text(text_len:) = 'Sonntag'
		text_len = 7
		set_uaf_day = 'SECONDARY'
	end if
c
	if (art_time.eq.daylight) then
		log_text(text_len+1:) = ' --> SOMMERZEITBEGINN'
		text_len = text_len + 21
	else if (art_time.eq.normal) then
		log_text(text_len+1:) = ' --> NORMALZEITBEGINN'
		text_len = text_len + 21
	end if
c
c*-----------------------------------------------------------------------
c	Kommando SET DAY/SECONDARY im Subprozess ausfuehren
c 
	if (set_uaf_day.ne.' ') then
		stat = lib$spawn ('SET DAY/'//set_uaf_day,,,,,,,)
		if (.not.stat) call lib$stop(%val(stat))
	end if
c
c*------------------------------------------------------------------------
c	Logical in LNM$SYSTEM neu setzen
c
	stat = lib$set_logical (log_name,log_text(:text_len),table)
	if (.not.stat) call lib$stop(%val(stat))
c
c*------------------------------------------------------------------------
c	OPCOM- Start-Message
c
	if (start.eq.0) then
		call request ('SETDAY gestartet')
		start = 1
	end if
c
c*--------------------------------------------------------------------------
c	Timer auf naechsten Tag 00:00 Uhr stellen und warten
c
	call lib$convert_date_string ('TOMORROW',morgen)
c
c*---------------------------------------------------------------------------
c
	stat = sys$setimr (%val(morgen_flg),morgen,,,)
	if (.not.stat) call lib$stop(%val(stat))
c
	stat = sys$waitfr (%val(morgen_flg))
	if (.not.stat) call lib$stop(%val(stat))
c
c*---------------------------------------------------------------------------
c
	goto 50
c
700	end
c
c***************************************************************************
c	Diese Routine wird am Sonntag nach Fruehlingsbeginn um 02:00 Uhr
c	gestartet und stellt die Systemzeit um eine Stunde vor.
c
	subroutine	springtime
c
	implicit	integer*4 (a-z)
c
	integer*4	one_hour_bin(2),current(2)
c
	common/one_hour_bin/one_hour_bin
c
	stat = sys$gettim(current)
	if (.not.stat) call lib$stop(%val(stat))
c
	call lib$add_times (current,one_hour_bin,current)
c
	stat = sys$setime (current)
	if (.not.stat) call lib$stop(%val(stat))
c
c	OPCOM - Sommerzeit-Message
c
	call request ('Systemzeit auf MEZ- Sommerzeit gesetzt')
c
	return
c
	end
c
c***************************************************************************
c	Diese Routine wird am Sonntag nach Herbstbeginn um 03:00 Uhr
c	gestartet und stellt die Systemzeit um eine Stunde zurueck.
c
	subroutine	falltime
c
	implicit	integer*4 (a-z)
c
	integer*4	one_hour_bin(2),current(2)
c
	common/one_hour_bin/one_hour_bin
c
	stat = sys$gettim(current)
	if (.not.stat) call lib$stop(%val(stat))
c
	call lib$sub_times (current,one_hour_bin,current)
c
	stat = sys$setime (current)
	if (.not.stat) call lib$stop(%val(stat))
c
c	OPCOM - MEZ-Message
c
	call request ('Systemzeit auf MEZ gesetzt')
c
	return
c
	end
c
c************************************************************************
c	OPCOM- Message to Security Operator
c
	subroutine	request (text)
c
	implicit	integer*4 (a-z)
c
	character	message*80, text*(*)
	integer*4	req (80/4)
c
	include 	'($opcdef)'
c
	equivalence 	(message,req)
c
	req(1)=opc$_rq_rqst.or.opc$m_nm_security
	req(2)=0
	message (9:80) = text(1:min(72,len(text)))
c
	stat = sys$sndopr(message,)
	if(.not.stat) call lib$stop(%val(ist))
c
	return
c
	end