home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / forum5.lzh / SPRACHEN / FORTRAN / BIORY / biory.f < prev   
Text File  |  1988-04-04  |  10KB  |  310 lines
  1. OPTIONS CPU=68000  
  2.  
  3.       PROGRAM BIORY
  4. C
  5. C++----------------------------------------------------------------------------
  6. C
  7. C+1   BESCHREIBUNG :
  8. C       BIORY berechnet den Biorhythmus fuer ein oder mehrere Jahre sowie
  9. C       fuer eine oder mehrere Personen.
  10. C       Der Benutzer wird nach dem Programmaufruf nach dem Namen, Geburts-
  11. C       Datum sowie der gewuenschten Zeitspanne gefragt. Die Eingabeformate
  12. C       sind selbsterklaerend.
  13. C       Die Ergebnisse werden in ein File (Biory.Lis) geschrieben.
  14. C-1
  15. C+2   PARAMETER :
  16. C-2
  17. C+3   GERUFENE SUBROUTINEN/FUNCTIONS :
  18. C       DATCON, DATCO1
  19. C-3
  20. C+4   CALL-BEISPIEL :
  21. C-4
  22. C+5   BEMERKUNGEN :
  23. C       Da die verwendete RTF-Version noch etwas muehsam in Bezug auf File-IO
  24. C       ist, muss mit der "OPEN/CLOSE/CALL shell('del ...')"-Kombination erst
  25. C       einmal ein eventuell vorhandenes Listing-File weggeputzt werden.
  26. C       (--> Hoffen auf baldige Besserung !)
  27. C-5
  28. C+6   COPYRIGHT :
  29. C       Nur fuer nichtkommerzielle Nutzung freigegeben !
  30. C-6
  31. C+7   HARDWARE :
  32. C       GEPARD 68000, 1 Sony-Laufwerk 3.5", 1.5MB RAM, 30 MB Harddisk,
  33. C       80-Zeichen-Karte, Seriell-Parallel-Karte MTH3
  34. C-7
  35. C+8   BETRIEBSSYSTEM/VERSION, COMPILER/VERSION :
  36. C       Professional OS-9 V2.1, RTF-Fortran V2.14
  37. C-8
  38. C+9   AUTOR(EN), ADRESSE, KURZZEICHEN :
  39. C       EGA : Andreas Eggenberger, Butzenstrasse 30,    Tel-P:     01/761 42 27
  40. C             CH-8910 Affoltern a/A                     Tel-G:     01/249 24 96
  41. C-9
  42. C+A   DATUM, AENDERUNGEN, VERSION :
  43. C       02.04.88/EGA : V1.0 Urversion
  44. C-A
  45. C------------------------------------------------------------------------------
  46. C
  47.       IMPLICIT NONE
  48. C
  49.       SAVE MONBEZ, PERIODE, ART, MAXTAG, PERZAHL, FILENAME
  50. C
  51.       INTEGER         LEN
  52.       INTEGER         ETAG, EMON, EJAHR, EVON, EBIS, ISTART, IJETZT
  53.       INTEGER         I, J, L, IP, IM, IJ, IFLAG, IX, IDIFF, IANZ
  54.       INTEGER         MAXTAG(12)
  55.       INTEGER         PERZAHL(3)
  56.       CHARACTER*28    ENAME
  57.       CHARACTER*31    TAGE
  58.       CHARACTER*9     MONBEZ(12)
  59.       CHARACTER*7     ART(3)
  60.       CHARACTER*66    PERIODE(3)
  61.       CHARACTER*30    FILENAME
  62. C
  63.       DATA MAXTAG / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /
  64. C
  65.       DATA MONBEZ / 'Januar', 'Februar', 'Maerz',   'April',
  66.      1              'Mai',    'Juni',    'Juli',    'August',
  67.      1              'September', 'Oktober', 'November', 'Dezember' /
  68. C
  69.       DATA PERZAHL / 23, 28, 33 /
  70. C
  71.       DATA ART     / 'Koerper', 'Seele', 'Geist' /
  72. C
  73.       DATA PERIODE /
  74.      1 'K**********K           K**********K           K**********K        ',
  75.      1 'K*************K             K*************K             K*********',
  76.      1 'K***************K                K***************K' /
  77. C
  78.       DATA FILENAME / 'Biory.Lis' /
  79. C
  80. C---------------------------------code-----------------------------------------
  81. C
  82.       L = LEN(FILENAME(:-1))
  83.       OPEN (10, FILE=FILENAME(:L))         ! File muss zum loeschen auf jeden
  84.       CLOSE (10)                           ! Fall existieren, da sonst
  85.       CALL shell ('del '//FILENAME(:L), I) ! Fehlermeldungen entstehen !
  86. C
  87.       OPEN (10, FILE=FILENAME(:L))
  88.       type *, '  Ausgabe im Listingfile "' // FILENAME(:L) // '"'
  89. C
  90.       DO FOREVER
  91.         WRITE (*,8091)
  92.         READ (*,9001,END=999) ENAME
  93.         IF (ENAME .EQ. ' ') THEN
  94.             CLOSE (10)
  95.             STOP 'BIO / NORMAL END'
  96.         END IF
  97.         WRITE (*,8092)
  98.         READ (*,9002) ETAG, EMON, EJAHR
  99.         EJAHR = EJAHR + 1900
  100.         WRITE (*,8093)
  101.         READ (*,9003) EVON, EBIS
  102.         EVON = EVON + 1900
  103.         EBIS = EBIS + 1900
  104.         IF (EBIS .LT. EVON) EBIS = EVON
  105.         CALL DATCON(ETAG,EMON,EJAHR,ISTART,IFLAG)
  106.         DO IJ = EVON, EBIS
  107.             WRITE (10,8001) ENAME, ETAG, EMON, EJAHR-1900
  108.             MAXTAG(2) = 28
  109.             IF (MOD(IJ,4) .EQ. 0) MAXTAG(2) = 29
  110.             IF (MOD(IJ,100) .EQ. 0) MAXTAG(2) = 28
  111.             IF (MOD(IJ,400) .EQ. 0) MAXTAG(2) = 29
  112.             CALL DATCON(1,1,IJ,IJETZT,IFLAG)
  113.             IDIFF = IJETZT - ISTART
  114.             IANZ = 0
  115.             DO IM = 1,12
  116.                 WRITE (10,8002) MONBEZ(IM), IJ
  117.                 DO IP = 1,3
  118.                     IX = MOD(IDIFF+IANZ,PERZAHL(IP)) + 1
  119.                     IF (IX .LT. 1) IX = IX + PERZAHL(IP)
  120.                     TAGE = PERIODE(IP)(IX:IX+MAXTAG(IM)-1)
  121.                     WRITE (10,8003) TAGE, ART(IP)
  122.                 END DO
  123.                 IANZ = IANZ + MAXTAG(IM)
  124.             END DO
  125.             WRITE (10,8004)
  126.             WRITE (10,*) CHAR(12)  ! FormFeed
  127.         END DO
  128.       END DO
  129. 999   CONTINUE
  130. C
  131. 8001  FORMAT (' ', T10, 'Biorhythmogramm fuer ', A28,
  132.      1       T60, '(', I2.2, '.', I2.2, '.', I2.2, ')', /,
  133.      1       ' ', T10, 60('='))
  134. C
  135. 8002  FORMAT (/, ' ', T10, A9, T20, I4, ' :',
  136.      1       T30, '1...5...10...15...20...25...30.')
  137. C
  138. 8003  FORMAT (' ', T30, A31, T63, A7)
  139. C
  140. 8004  FORMAT (/, ' ', T10, 'Erklaerungen :',
  141.      1       T30, '-  K  = kritisch (+- 1 Tag)', /,
  142.      1       ' ', T30, '- *** = Hochphase', /,
  143.      1       ' ', T30, '-     = Tiefphase')
  144. C
  145. 8091  FORMAT ('  Name Vorname (RETURN=Ende)  : $')
  146. 8092  FORMAT ('  Geburtsdatum (TTMMJJ)       : $')
  147. 8093  FORMAT ('  Gueltigkeitsbereich (JJ-JJ) : $')
  148. C
  149. 9001  FORMAT (A28)
  150. 9002  FORMAT (I2,I2,I2)
  151. 9003  FORMAT (I2,1X,I2)
  152. C
  153.       END
  154. C
  155. C==============================================================================
  156. C
  157.         SUBROUTINE DATCON (TT, MM, JJ, T, E0)
  158. C
  159. C++----------------------------------------------------------------------------
  160. C
  161. C+1   BESCHREIBUNG :
  162. C       DATCON berechnet die Anzahl Tage zwischen dem 1.1.1801 und TT.MM.JJ
  163. C-1
  164. C+2   PARAMETER :
  165. C       TT, MM, JJ : Tag, Monat, Jahr
  166. C       T          : Ergebnis : Anzahl Tage
  167. C       E0         : Error-Flag : 1 = Datum nicht moeglich, 0 = Okay
  168. C-2
  169. C+3   GERUFENE SUBROUTINEN/FUNCTIONS :
  170. C-3
  171. C+4   CALL-BEISPIEL :
  172. C       CALL DATCON (11, 1, 1988, IANZ, IERR)
  173. C-4
  174. C+5   BEMERKUNGEN :
  175. C-5
  176. C+6   COPYRIGHT :
  177. C       Nur fuer nichtkommerzielle Nutzung freigegeben !
  178. C-6
  179. C+7   HARDWARE :
  180. C       GEPARD 68000, 1 Sony-Laufwerk 3.5", 1.5MB RAM, 30 MB Harddisk,
  181. C       80-Zeichen-Karte, Seriell-Parallel-Karte MTH3
  182. C-7
  183. C+8   BETRIEBSSYSTEM/VERSION, COMPILER/VERSION :
  184. C       Professional OS-9 V2.1, RTF-Fortran V2.14
  185. C-8
  186. C+9   AUTOR(EN), ADRESSE, KURZZEICHEN :
  187. C       EGA : Andreas Eggenberger, Butzenstrasse 30,    Tel-P:     01/761 42 27
  188. C             CH-8910 Affoltern a/A                     Tel-G:     01/249 24 96
  189. C-9
  190. C+A   DATUM, AENDERUNGEN, VERSION :
  191. C       02.04.88/EGA : V1.0 Urversion
  192. C-A
  193. C------------------------------------------------------------------------------
  194. C
  195.       IMPLICIT NONE
  196. C
  197.       INTEGER IT, TT, MM, JJ, T, TTAB(12), E0, X0, X1, X2, X3, X4, X5, I
  198.       SAVE TTAB
  199.       DATA TTAB / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /
  200. C
  201.       E0 = 0          ! Return-Code auf Null (kein Fehler)
  202. C
  203.       IF (JJ.LT.1801 .OR. JJ.GT.2099) THEN
  204.           WRITE (*,*) 'Fehler : Jahreszahl ungueltig !'
  205.           E0 = 1        ! Fehler !
  206.       END IF
  207.       IF (MM.LT.1 .OR. MM.GT.12) THEN
  208.           WRITE (*,*) 'Fehler : Monat ungueltig !'
  209.           E0 = 1        ! Fehler !
  210.       END IF
  211.       TTAB(2) = 28
  212.       IF (MOD(JJ,4) .EQ. 0) TTAB(2) = 29      ! Schaltjahr
  213.       IF (MOD(JJ,100) .EQ. 0) TTAB(2) = 28    ! bzw. doch kein Schaltjahr
  214.       IF (MOD(JJ,400) .EQ. 0) TTAB(2) = 29    ! trotzdem ein Schaltjahr
  215.       IF (TT.LT.1 .OR. TT.GT.TTAB(MM)) THEN
  216.           WRITE (*,*) 'Fehler : Tag ungueltig !'
  217.           E0 = 1        ! Fehler !
  218.       END IF
  219.       IF (E0 .NE. 0) RETURN                   ! ***** ERROR EXIT ***** !
  220. C
  221. C***    eigentliche Rechnung :
  222. C
  223.       X0 = JJ - 1801
  224.       X1 = INT(X0/4) * 1461
  225.       X2 = MOD(X0,4) * 365
  226.       T  = X1 + X2 - INT(X0/100) + INT((X0+200)/400)
  227. C
  228.       I = 1
  229. C
  230.       DO WHILE (I .LT. MM)
  231.           T = T + TTAB(I)
  232.           I = I + 1
  233.       END DO
  234. C
  235.       T = T + TT
  236. C
  237.       RETURN                                   ! ... und zurueck
  238.       END
  239. C
  240. C==============================================================================
  241. C
  242.       SUBROUTINE DATCO1 (T, TT, MM, JJ)
  243. C
  244. C++----------------------------------------------------------------------------
  245. C
  246. C+1   BESCHREIBUNG :
  247. C       DATCO1 ist die komplementaere Funktion zu DATCON : Es wird das Datum
  248. C       (TT, MM, JJ) berechnet, das vom 1.1.1801 "T" Tage entfernt ist.
  249. C-1
  250. C+2   PARAMETER :
  251. C       T          : Anzahl Tage
  252. C       TT, MM, JJ : Ergebnis : Tag, Monat, Jahr
  253. C-2
  254. C+3   GERUFENE SUBROUTINEN/FUNCTIONS :
  255. C-3
  256. C+4   CALL-BEISPIEL :
  257. C       CALL DATCO1 (IANZ, TT, MM, JJ)
  258. C-4
  259. C+5   BEMERKUNGEN :
  260. C-5
  261. C+6   COPYRIGHT :
  262. C       Nur fuer nichtkommerzielle Nutzung freigegeben !
  263. C-6
  264. C+7   HARDWARE :
  265. C       GEPARD 68000, 1 Sony-Laufwerk 3.5", 1.5MB RAM, 30 MB Harddisk,
  266. C       80-Zeichen-Karte, Seriell-Parallel-Karte MTH3
  267. C-7
  268. C+8   BETRIEBSSYSTEM/VERSION, COMPILER/VERSION :
  269. C       Professional OS-9 V2.1, RTF-Fortran V2.14
  270. C-8
  271. C+9   AUTOR(EN), ADRESSE, KURZZEICHEN :
  272. C       EGA : Andreas Eggenberger, Butzenstrasse 30,    Tel-P:     01/761 42 27
  273. C             CH-8910 Affoltern a/A                     Tel-G:     01/249 24 96
  274. C-9
  275. C+A   DATUM, AENDERUNGEN, VERSION :
  276. C       02.04.88/EGA : V1.0 Urversion
  277. C-A
  278. C------------------------------------------------------------------------------
  279. C
  280.       IMPLICIT NONE
  281. C
  282.       INTEGER IT, TT, MM, JJ, T, TTAB(12), E0, X0, X1, X2, X3, X4, X5, I
  283.       SAVE TTAB
  284.       DATA TTAB / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /
  285. C
  286.       IT = T
  287.       IF (IT .GT. 36524) IT = IT + 1
  288.       X1 = INT((IT-1)/1461)                   ! Anzahl 4-Jahres Gruppen
  289.       X2 = MOD(IT-1,1461) + 1                 ! verbleibende Tage
  290.       X3 = 0
  291. C
  292.       DO WHILE (X3 .LT. 2 .AND. X2 .GT. 365)
  293.           X2 = X2 - 365
  294.           X3 = X3 + 1
  295.       END DO
  296. C
  297.       JJ = X1*4 + X3 + 1801
  298.       TTAB(2) = 28
  299.       IF (MOD(JJ,4) .EQ. 0) TTAB(2) = 29      ! Schaltjahr
  300.       IF (MOD(JJ,100) .EQ. 0) TTAB(2) = 28    ! bzw. doch kein Schaltjahr
  301.       IF (MOD(JJ,400) .EQ. 0) TTAB(2) = 29    ! trotzdem ein Schaltjahr
  302.       DO MM = 1, 12
  303.           IF (X2 .LE. TTAB(MM)) GOTO 200
  304.           X2 = X2 - TTAB(MM)
  305.       END DO
  306. 200   CONTINUE
  307.       TT = X2
  308.       RETURN                                  ! ... und zurueck
  309.       END
  310.