SUBROUTINE BL_TO_GK
1 (Z,Y,X,MEDI,R,H,ZNN)
C DIESES PROGRAMM RECHNET VOM GEOGRAPHISCHEN LAENGE-BREITE-SYSTEM IN GAUSS-
C KRUEGER KOORDINATEN UM.
C DIE EINGABE PARAMETER :
C Z : DIE WAHRE TEUFE MIT Z=0. AM BOHRLOCHMUND,HIER WIRD DIE START-
C HOEHE ZNN DES GK-SYSTEMS EINGESETZT. ALLE WEITEREN Z WERTE
C WERDEN NUN SUBTRAHIERT.
C Y : HIER DIE NORDABWEICHUNG (IM GEGENSATZ ZUM GEODAETISCHEN SYSTEM).
C Y MUSS MIT DEM COSINUS DER MERIDIANKONVERGENZ MULTIPLIZIERT
C WERDEN UND MIT DEM HOCHWERT DER STARTKOORDINATE ADDIERT.
C X : ES WIRD NUR DER RECHTSWERT DER STARTKOORDINATE ADDIERT.
C MEDI : DIE MERIDIANKONVERGENZ AUS TABELLE ODER SUBROUTINE MK ODER
C PROGRAM T_MK.ES WIRD DARAUF VERZICHTET MK STAENDIG NEU ZU RECHNEN.
C R : RECHTSWERT , BEIM ERSTEN LAUF R VON STARTKOORDINATE
C H : HOCHWERT, BEIM ERSTEN LAUF H VON STARTKOORDINATE
C ZNN : HOEHE UEBER NORMALNULL ,BEIM ERSTEN LAUF H VON STARTKOORDINATE
C JP MAR 88
IMPLICIT NONE
REAL MEDI
DOUBLE PRECISION
1 Z,
1 Y,
1 X,
1 R,
1 H,
1 ZNN,
1 R_REF, !GK-KOORDINATEN DES STARTPUNKTES
1 H_REF, !
1 ZNN_REF !
CHARACTER*1 FR
C SAVE FR,R_REF,H_REF,ZNN_REF
C BEGIN :
IF (FR .NE. 'N') THEN
C <SICHERE STARTKOORDINATEN>
R_REF = R
H_REF = H
ZNN_REF = ZNN
FR = 'N'
END IF
C <TRANSFORMIERE>
R = R_REF + X
H = H_REF + Y*DBLE(COS(MEDI))
ZNN = ZNN_REF - Z
C END;
RETURN
END
SUBROUTINE COMP_DEP_COOR
1 (RET_STAT,UNIT_NO1,
1 L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,
1 FBLK_NO,
1 FBLK_NO1,ROW1,
1 FBLK_NO2,ROW2,
1 DESDEP,
1 LX,LY,LZ,ERR_LX,ERR_LY,ERR_LZ)
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE COORDINATES OF SPECIFIED LAYERS. THE COORDINATES
C FROM DEVIATIONLOG ARE STORED IN A DTV-FILE WITH DATA-KIND 12 AND DR-DECL-FORMAT.
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !!
C INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
INCLUDE 'DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(COM_FBLK)'
LOGICAL
1 L_TANMET, !
1 L_BATAME,
1 L_ANGAVE,
1 L_RADIOC
INTEGER
* FBLK_NO, !FILEBLOCK NUMBER
* FBLK_NO1, !FILEBLOCK NUMBER
* FBLK_NO2, !FILEBLOCK NUMBER
* F_NEXT, !NEXT FILEBLOCK OF SAME DATA KIND
* B_NEXT, !PREVIOUS FILEBLOCK OF SAME DATA KIND
1 ROW1,
1 ROW2,
1 UNIT_NO1, !DTV-FILE
5 RET_STAT
REAL
1 DESDEP, !DESIRED DEPTH
1 DESAZI,
1 DESDIP,
1 ERR_LX,
1 ERR_LY,
1 ERR_LZ,
1 ERR_X1,ERR_X2,
1 ERR_Y1,ERR_Y2,
1 ERR_Z1,ERR_Z2,
1 M_DEPTH1,M_DEPTH2,
1 DIP1,DIP2,
1 AZI1,AZI2,
1 FAKTOR,
1 NENNER,
1 DIPDIFF,
1 AZIDIFF,
1 DELTA_DEPTH,
1 COURSE_LEN
DOUBLE PRECISION !MP-KOORDINATEN IM GAUSS-KRUEGER-SYSTEM
1 Z1,Z2, !MEASURED Z-COORDINATE
1 Y1,Y2,
1 X1,X2,
1 LZ,
1 LY,
1 LX,
1 DBUFF(3),
1 S1(3),S2(3) !EINHEITSVECTOR(S) STUETZSTELLEN
C BEGIN:
IF (L_TANMET .OR. L_BATAME .OR. L_ANGAVE .OR. L_RADIOC) THEN !COMPUTE
IF (FBLK_NO1 .NE. FBLK_NO)
1CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO1,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
C <GET MEASURED COORDINATES FROM 1.STUETZSTELLE>
MSX = FB_DATA(P_MSX + ROW1*DR$X_SIZE)
LSX = FB_DATA(P_LSX + ROW1*DR$X_SIZE)
CALL EXT_2RIDP (X1,MSX,LSX)
MSY = FB_DATA(P_MSY + ROW1*DR$X_SIZE)
LSY = FB_DATA(P_LSY + ROW1*DR$X_SIZE)
CALL EXT_2RIDP (Y1,MSY,LSY)
MSZ = FB_DATA(P_MSZ + ROW1*DR$X_SIZE)
LSZ = FB_DATA(P_LSZ + ROW1*DR$X_SIZE)
CALL EXT_2RIDP (Z1,MSZ,LSZ)
ERR_X1 = FB_DATA(P_ERR_X + ROW1*DR$X_SIZE)
ERR_Y1 = FB_DATA(P_ERR_Z + ROW1*DR$X_SIZE)
ERR_Z1 = FB_DATA(P_ERR_Z + ROW1*DR$X_SIZE)
M_DEPTH1= FB_DATA (P_M_DEPTH + ROW1*DR$X_SIZE)
AZI1 = FB_DATA (P_AZI + ROW1*DR$X_SIZE)
DIP1 = FB_DATA (P_DIP + ROW1*DR$X_SIZE)
C <GET MEASURED COORDINATES FROM 2.STUETZSTELLE>
IF (ROW2 .NE. ROW1)THEN
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO2,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
END IF
MSX = FB_DATA(P_MSX + ROW2*DR$X_SIZE)
LSX = FB_DATA(P_LSX + ROW2*DR$X_SIZE)
CALL EXT_2RIDP (X2,MSX,LSX)
MSY = FB_DATA(P_MSY + ROW2*DR$X_SIZE)
LSY = FB_DATA(P_LSY + ROW2*DR$X_SIZE)
CALL EXT_2RIDP (Y2,MSY,LSY)
MSZ = FB_DATA(P_MSZ + ROW2*DR$X_SIZE)
LSZ = FB_DATA(P_LSZ + ROW2*DR$X_SIZE)
CALL EXT_2RIDP (Z2,MSZ,LSZ)
ERR_X2 = FB_DATA(P_ERR_X + ROW2*DR$X_SIZE)
ERR_Y2 = FB_DATA(P_ERR_Z + ROW2*DR$X_SIZE)
ERR_Z2 = FB_DATA(P_ERR_Z + ROW2*DR$X_SIZE)
M_DEPTH2= FB_DATA (P_M_DEPTH + ROW2*DR$X_SIZE)
AZI2 = FB_DATA (P_AZI + ROW2*DR$X_SIZE)
DIP2 = FB_DATA (P_DIP + ROW2*DR$X_SIZE)
C <COMPUTE DESIRED COORDINATES>
IF (L_TANMET .OR. L_ANGAVE) THEN
S1(1) = X2-X1
S1(2) = Y2-Y1
S1(3) = Z2-Z1
IF (M_DEPTH1 .EQ. M_DEPTH2) THEN
LX = X1
LY = Y1
LZ = Z1
ELSE
FAKTOR = DBLE((DESDEP-M_DEPTH1)/(M_DEPTH2-M_DEPTH1))
LX = X1 + S1(1)*FAKTOR
LY = Y1 + S1(2)*FAKTOR
LZ = Z1 + S1(3)*FAKTOR
END IF
D WRITE (13,*) 'DESDEP',DESDEP
D WRITE (13,*) 'X1,X2 ',X1,X2
D WRITE (13,*) 'Y1,Y2 ',Y1,Y2
D WRITE (13,*) 'Z1,Z2 ',Z1,Z2
D WRITE (13,*) 'S1(3) ',S1
D WRITE (13,*) 'FAKTOR',FAKTOR
D WRITE (13,*) 'LXYZ ',LX,LY,LZ
D WRITE (13,*)
END IF
IF (L_BATAME) THEN
IF (DESDEP-M_DEPTH1 .LE. M_DEPTH2-DESDEP) THEN
C <FIRST TANGENT>
DBUFF(1) = DBLE(SIN(DIP1)*SIN(AZI1))
DBUFF(2) = DBLE(SIN(DIP1)*COS(AZI1))
DBUFF(3) = DBLE(COS(DIP1))
CALL VEKTOR_DNORM (DBUFF,S1)
LX = X1 + DBLE((DESDEP-M_DEPTH1))*S1(1)
LY = Y1 + DBLE((DESDEP-M_DEPTH1))*S1(2)
LZ = Z1 + DBLE((DESDEP-M_DEPTH1))*S1(3)
S2(1) = 0.
S2(2) = 0.
S2(3) = 0.
ELSE
C <2ND TANGENT>
DBUFF(1) = DBLE(SIN(DIP2)*SIN(AZI2))
DBUFF(2) = DBLE(SIN(DIP2)*COS(AZI2))
DBUFF(3) = DBLE(COS(DIP2))
CALL VEKTOR_DNORM (DBUFF,S2)
LX = X2 - DBLE((M_DEPTH2-DESDEP))*S2(1)
LY = Y2 - DBLE((M_DEPTH2-DESDEP))*S2(2)
LZ = Z2 - DBLE((M_DEPTH2-DESDEP))*S2(3)
S1(1) = 0.
S1(2) = 0.
S1(3) = 0.
END IF
D WRITE (13,*) 'DESDEP',DESDEP
D WRITE (13,*) 'X1,X2 ',X1,X2
D WRITE (13,*) 'Y1,Y2 ',Y1,Y2
D WRITE (13,*) 'Z1,Z2 ',Z1,Z2
D WRITE (13,*) 'S1(3) ',S1
D WRITE (13,*) 'S2(3) ',S2
D WRITE (13,*) 'LXYZ ',LX,LY,LZ
D WRITE (13,*)
END IF
IF (L_RADIOC) THEN ! ACHTUNG,DIESES VERFAHREN IST ETWAS
C EMFINDLICH WENN DIE DIFFERENZ ZWISCHEN ZWEI WINKELN GROESSER
C ALS 180 GRAD WIRD. DIE URSACHE LIEGT IN DER DIFFERENZENBILDUNG.
IF (ABS(AZI1-AZI2) .GE. PI) THEN
IF (AZI1 .GT. PI) AZI1 = AZI1 - 2.*PI
IF (AZI2 .GT. PI) AZI2 = AZI2 - 2.*PI
END IF
DESDIP = DESDEP/M_DEPTH2*(DIP2-DIP1) + DIP1
DESAZI = DESDEP/M_DEPTH2*(AZI2-AZI1) + AZI1
IF (DESDIP .LT. 0.) DESDIP = DESDIP + 2.*PI
IF (DESDIP .GE. 2.*PI) DESDIP = DESDIP - 2.*PI
IF (DESAZI .LT. 0.) DESAZI = DESAZI + 2.*PI
IF (DESAZI .GE. 2.*PI) DESAZI = DESAZI - 2.*PI
IF (ABS(DESAZI-AZI1) .GE. PI) THEN
IF (AZI1 .GT. PI) AZI1 = AZI1 - 2.*PI
IF (DESAZI .GT. PI) DESAZI = DESAZI - 2.*PI
END IF
DIPDIFF = DESDIP - DIP1
AZIDIFF = DESAZI - AZI1
NENNER = DIPDIFF * AZIDIFF
COURSE_LEN = DESDEP - M_DEPTH1
IF (DIPDIFF .NE. 0.) THEN
DELTA_DEPTH = COURSE_LEN * (SIN(DESDIP)-SIN(DIP1)) /
1 DIPDIFF
ELSE
DELTA_DEPTH = COURSE_LEN * COS (DIP1)
END IF
LZ = DBLE(DELTA_DEPTH) + Z1
IF (NENNER .NE. 0.) THEN
LY = DBLE(COURSE_LEN * (COS(DIP1)-COS(DESDIP)) *
1 (SIN(DESAZI)-SIN(AZI1)) / NENNER ) + Y1
LX = DBLE(COURSE_LEN * (COS(DIP1)-COS(DESDIP)) *
1 (COS(AZI1)-COS(DESAZI)) / NENNER ) + X1
ELSE
LY = DBLE(COURSE_LEN * SIN((DIP1+DESDIP)/2.) *
1 COS((DESAZI+AZI1)/2.) ) + Y1
LX = DBLE(COURSE_LEN * SIN((DIP1+DESDIP)/2.) *
1 SIN((DESAZI+AZI1)/2.) ) + X1
END IF
D WRITE (13,*) 'DESDEP,DIP,AZI',DESDEP,DESDIP/DEGRAD,DESAZI/DEGRAD
D WRITE (13,*) 'X1,X2 ',X1,X2
D WRITE (13,*) 'Y1,Y2 ',Y1,Y2
D WRITE (13,*) 'Z1,Z2 ',Z1,Z2
D WRITE (13,*) 'LXYZ ',LX,LY,LZ
D WRITE (13,*)
END IF
IF (FBLK_NO .NE. FBLK_NO2)
1 CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
C END;
RETURN
ELSE !WRONG L_xxxxxx PARAMETER!:
RET_STAT = 99
END IF
RETURN
END
CZCZ
SUBROUTINE COMP_LA_COOR
1 (RET_STAT,UNIT_NO1,UNIT_NO2,UNIT_NO3,R_DIB,R_DIE,DIBNB,DIBNE,
1 L_REF,L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,MEDI,R,H,ZNN)
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE COORDINATES OF SPECIFIED LAYERS. THE COORDINATES
C FROM DEVIATIONLOG ARE STORED IN A DTV-FILE WITH DATA-KIND 12 AND DR-DECL-FORMAT.
C MEASURED LAYER DEPTH AND NAMES ARE STORED IN LAY_'FILE_NAME'.DAT . THE DEPTH
C HAVE TO BE STORED INTO DESCENDING ORDER!!
C FLOWCHART: 1. READ DESIRED DEPTH FROM LAY_XXXXX (UNIT_NO2)
C 2. SEARCH DEPTH NEXT TO DESIRED DEPTH
C 3. COMPUTE COORDINATES
C 4. STORE COORDINATES INTO SCHEDULE-FILE
C 5. EXIT
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !!
C INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
INCLUDE 'DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(COM_FBLK)'
INCLUDE '(LOC_FSH)'
LOGICAL
1 L_TANMET, !
1 L_BATAME,
1 L_ANGAVE,
1 L_RADIOC,
1 L_ERROR,
1 L_WRONGDEPTH,
1 L_REF,
1 L_DEPB_FOUND,
1 L_DEPE_FOUND
CHARACTER*3 TOOL
CHARACTER*15 LAYER
INTEGER
* DATA_KIND,
* FBLK_NO, !FILEBLOCK NUMBER
1 LAST_FBLK_NO,
* B_NEXT, !PREVIOUS FILEBLOCK OF SAME DATA KIND
* F_NEXT, !NEXT FILEBLOCK OF SAME DATA KIND
1 DIBNB,
1 DIBNE,
1 MDEP_FB_B1, !MEASURED DEPTH FILEBLOCK BEGIN
1 MDEP_FB_E1, ! END
1 MDEP_ROW_B1, !MEASURED DEPTH ROW BEGIN
1 MDEP_ROW_E1, ! END
1 MDEP_FB_B2, !MEASURED DEPTH FILEBLOCK BEGIN
1 MDEP_FB_E2, ! END
1 MDEP_ROW_B2, !MEASURED DEPTH ROW BEGIN
1 MDEP_ROW_E2, ! END
1 ROW,
1 LAST_ROW,
1 UNIT_NO1, !DTV-FILE
1 UNIT_NO2, !LAYER-IN-FILE
1 UNIT_NO3, !COMPLETE LAYER-FILE
5 RET_STAT,
1 IOERR
REAL
1 M_DEPTH_OLD,
1 R_DIB, !LOGGING INTERVAL BEGIN
1 R_DIE, !LOGGING INTERVAL END
1 DESDEP_B, !DESIRED DEPTH BEGIN
1 DESDEP_E, !DESIRED DEPTH END
1 ERR_LX1, !ERROR OF COORDINATES..
1 ERR_LX2,
1 ERR_LY1,
1 ERR_LY2,
1 ERR_LZ1,
1 ERR_LZ2
DOUBLE PRECISION !MP-KOORDINATEN IM GAUSS-KRUEGER-SYSTEM
1 R,R1,R2, !RECHTS
1 H,H1,H2, !HOCH
1 ZNN,ZNN1,ZNN2, !MIT Z IST HIER DIE HOEHE UEBER NN GEMEINT !!
1 LZ1,LZ2, !WAHRE TEUFE , POSITIVE RICHTUNG NACH UNTEN
1 LY1,LY2, !HIER:NORDABWEICHUNG
1 LX1,LX2 !HIER:OSTABWEICHUNG
INTEGER KEZI !KENNZIFFER
REAL MEDI !MERIDIANKONVERGENZ IN RAD
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'SUBPROGRAM "COMP-LA-COOR". JP MAR.88'
WRITE(*,*)
IF (L_TANMET .OR. L_BATAME .OR. L_ANGAVE .OR. L_RADIOC) THEN
WRITE(*,*) 'COMPUTE...'
R1 = R
H1 = H
ZNN1 = ZNN
FBLK_NO = DIBNB
LAST_FBLK_NO = DIBNB
LAST_ROW = 0
READ (UNIT_NO2,END=999,IOSTAT=IOERR) LAYER,DESDEP_B,DESDEP_E
L_DEPB_FOUND = .FALSE.
L_DEPE_FOUND = .FALSE.
DO WHILE (FBLK_NO .LE. DIBNE .AND. FBLK_NO .NE. 0)
D TYPE *,'ACTUAL FBLK: ',FBLK_NO
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
M_DEPTH = FB_DATA (P_M_DEPTH)
TYPE_OF_TOOL = FB_DATA (P_TYPE_OF_TOOL)
ROW = 0
DO WHILE ((ROW .LT. DR$X_SIZE) .AND. (TYPE_OF_TOOL .NE. 0.))
D TYPE *,'ACTUAL ROW : ',ROW
M_DEPTH = FB_DATA (P_M_DEPTH + ROW*DR$X_SIZE)
TYPE_OF_TOOL = FB_DATA (P_TYPE_OF_TOOL + ROW*DR$X_SIZE)
C <SUCHE PASSENDE ZEILE IN BLOCK FUER GEWUENSCHTE ANFANGSTEUFE>
IF (M_DEPTH .EQ. DESDEP_B .AND. .NOT.L_DEPB_FOUND) THEN
MDEP_ROW_B1 = ROW
MDEP_FB_B1 = FBLK_NO
MDEP_ROW_B2 = ROW
MDEP_FB_B2 = FBLK_NO
L_DEPB_FOUND = .TRUE.
END IF
IF (M_DEPTH .GT. DESDEP_B .AND. .NOT.L_DEPB_FOUND) THEN
MDEP_ROW_B2 = ROW
MDEP_FB_B2 = FBLK_NO
MDEP_ROW_B1 = LAST_ROW
MDEP_FB_B1 = LAST_FBLK_NO
L_DEPB_FOUND = .TRUE.
END IF
C <SUCHE PASSENDE ZEILE IN BLOCK FUER GEWUENSCHTE ENDTEUFE>
IF (M_DEPTH .EQ. DESDEP_E .AND. .NOT.L_DEPE_FOUND) THEN
MDEP_ROW_E1 = ROW
MDEP_FB_E1 = FBLK_NO
MDEP_ROW_E2 = ROW
MDEP_FB_E2 = FBLK_NO
L_DEPE_FOUND = .TRUE.
END IF
IF (M_DEPTH .GT. DESDEP_E .AND. .NOT.L_DEPE_FOUND) THEN
MDEP_ROW_E2 = ROW
MDEP_FB_E2 = FBLK_NO
MDEP_ROW_E1 = LAST_ROW
MDEP_FB_E1 = LAST_FBLK_NO
L_DEPE_FOUND = .TRUE.
END IF
IF (L_DEPB_FOUND .AND. L_DEPE_FOUND) THEN
CALL COMP_DEP_COOR
1 (RET_STAT,UNIT_NO1,
1 L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,
1 FBLK_NO,
1 MDEP_FB_B1,MDEP_ROW_B1,MDEP_FB_B2,MDEP_ROW_B2,
1 DESDEP_B,
1 LX1,LY1,LZ1,ERR_LX1,ERR_LY1,ERR_LZ1)
CALL COMP_DEP_COOR
1 (RET_STAT,UNIT_NO1,
1 L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,
1 FBLK_NO,
1 MDEP_FB_E1,MDEP_ROW_E1,MDEP_FB_E2,MDEP_ROW_E2,
1 DESDEP_E,
1 LX2,LY2,LZ2,ERR_LX2,ERR_LY2,ERR_LZ2)
D TYPE *,'DESDEP_B,DESDEP_E : ',DESDEP_B,DESDEP_E
D TYPE *,'LZ1,LZ2 : ',LZ1,LZ2
D TYPE *,'LY1,LY2 : ',LY1,LY2
D TYPE *,'LX1,LX2 : ',LX1,LX2
D TYPE *,' '
C <WRITE LAYER-COORDINATES INTO NEW LAY_xxxxx.DAT FILE.>
IF (L_REF) THEN
CALL BL_TO_GK (LZ1,LY1,LX1,MEDI,R1,H1,ZNN1)
CALL BL_TO_GK (LZ2,LY2,LX2,MEDI,R2,H2,ZNN2)
WRITE (UNIT_NO3)
1 LAYER,DESDEP_B,DESDEP_E,
1 R1,ERR_LX1,H1,ERR_LY1,ZNN1,ERR_LZ1,
1 R2,ERR_LY2,H2,ERR_LY2,ZNN2,ERR_LZ2
ELSE
WRITE (UNIT_NO3)
1 LAYER,DESDEP_B,DESDEP_E,
1 LX1,ERR_LX1,LY1,ERR_LY1,LZ1,ERR_LZ1,
1 LX2,ERR_LX2,LY2,ERR_LY2,LZ2,ERR_LZ2
END IF
READ (UNIT_NO2,END=999,IOSTAT=IOERR)
1 LAYER,DESDEP_B,DESDEP_E
L_DEPB_FOUND = .FALSE.
L_DEPE_FOUND = .FALSE.
ELSE
LAST_ROW = ROW
LAST_FBLK_NO = FBLK_NO
M_DEPTH_OLD = M_DEPTH
ROW = ROW + 1
END IF
END DO !WHILE
FBLK_NO = F_NEXT
END DO !WHILE
IF (IOERR .EQ. 0) THEN
TYPE *,'***** OBACHT! END OF LAYER-IN-FILE N-O-T DETECTED... *****'
ELSE
999 CONTINUE
TYPE *,'END OF LAYER-IN-FILE DETECTED...'
END IF
RETURN
ELSE
L_ERROR = .TRUE.
END IF
9999 CONTINUE
IF (L_ERROR) RET_STAT = 999
RETURN
END
CZCZ
SUBROUTINE CREA_CL_LIST
1 (RET_STAT,UNIT_NO3,UNIT_NO2,
1 L_REF,L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,
1 SE_FHMOD,SE_FHEXE,
1 KEZI,MEDI,DECL,CABLEN,R,H,ZNN)
C-------EXPLANATION:
C THIS PROGRAM LISTS THE COORDINATES OF SPECIFIED LAYERS. THE COORDINATES
C ARE STORED IN A FILE CREATED BY SUBROUTINE COMP_LA_COOR.
C THE HEAD OF THE SCHEDULE WILL BE APPENDED LATER..
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !!
INTEGER
1 UNIT_NO2,
1 UNIT_NO3,
5 RET_STAT,
1 KEZI,
1 ROW_COUNTER,
1 IOERR,
1 OUTPUT
LOGICAL
1 L_TANMET, !
1 L_BATAME,
1 L_ANGAVE,
1 L_RADIOC,
1 L_FR,
1 L_REF
REAL
1 ERR_LX1,ERR_LX2,
1 ERR_LY1,ERR_LY2,
1 ERR_LZ1,ERR_LZ2,
1 DESDEP_B,DESDEP_E,
1 MEDI, !MERIDIANKONVERGENZ IN RAD
1 DECL, !DECLINATION MAGNETFELD IN RAD
1 DEGRAD, !GRAD ZU RAD
1 CABLEN, !MEASURED MAX. CABLE LENGTH DEVIATION LOG
1 TYPE_OF_TOOL
DOUBLE PRECISION !MP-KOORDINATEN IM GAUSS-KRUEGER-SYSTEM
1 R,R1,R2, !RECHTS
1 H,H1,H2, !HOCH
1 ZNN,ZNN1,ZNN2, !MIT Z IST HIER DIE HOEHE UEBER NN GEMEINT !!
1 LZ1,LZ2, !WAHRE TEUFE , POSITIVE RICHTUNG NACH UNTEN
1 LY1,LY2, !HIER:NORDABWEICHUNG
1 LX1,LX2 !HIER:OSTABWEICHUNG
CHARACTER*58 C_SONDE,
1 C_DATENBEARBEITUNG,
1 C_MESSTRUPP,
1 C_AUSWERTER,
1 C_AUFTRAGGEBER,
1 C_DATUM,
1 C_BOHRUNG,
1 C_REMARK
CHARACTER*40 LOCATION,
1 DATE
CHARACTER*1 ANSWER
CHARACTER*15 LAYER
CHARACTER*(*) SE_FHMOD !USED PROGRAM TO COMPUTE DEVIATION OF WELL
CHARACTER*(*) SE_FHEXE !EXECUTIVE OF PROGRAM
C.......VARIABLENNAMEN VON COMMAND_PROCEDURE :
CHARACTER*1 C_DUMP
CHARACTER*3 TOOL
CHARACTER*30 DATADIR
CHARACTER*30 PRINTDIR
PARAMETER (DEGRAD = .017453293)
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'SUBPROGRAM "CREA_CL_LIST". JP MAR/APR.88'
WRITE(*,*)
C LESE PARAMETER_FILE:
OPEN (UNIT=36,FILE='PARAMETER',
1 STATUS='OLD')
READ (36,'(A1)') C_DUMP
READ (36,'(A1)') C_DUMP
READ (36,'(A3)') TOOL
READ (36,'(A1)') C_DUMP
READ (36,'(A1)') C_DUMP
READ (36,'(A30)') DATADIR
READ (36,'(A30)') PRINTDIR
CLOSE (36,STATUS='KEEP')
DECODE (3,'(F3.1)',TOOL) TYPE_OF_TOOL
C-------BESCHRIFTUNG DER LISTE:
OUTPUT = UNIT_NO2
ROW_COUNTER = 12 !UEBERSCHRIFT KOMMT IN COMMANDOPROZEDUR NACHHER DAZU!
C.......EINGABE DER AUFTRAGGEBER ETC,ETC,..
WRITE(*,1100) 'AUFTRAGGEBER ? '
READ (*,'(A58)') C_AUFTRAGGEBER
WRITE (OUTPUT,5) C_AUFTRAGGEBER
5 FORMAT (1X,T2,'Auftraggeber : ',A58,/)
WRITE(*,1100) 'BOHRUNG ? '
READ (*,'(A58)') C_BOHRUNG
WRITE (OUTPUT,7) C_BOHRUNG
LOCATION = C_BOHRUNG (1:40)
7 FORMAT (1X,T2,'Bohrung : ',A58,/)
IF (L_REF) THEN
D TYPE *,'MERIDIANKONVERGENZ IN ALTGRAD : ',MEDI
WRITE (OUTPUT,81) R,KEZI, H,MEDI/DEGRAD/.9 ,ZNN
81 FORMAT (1X,T2,'Startkoordinaten : ',
1 'R : ',F11.2,' m ,',I2,'. Meridianstreifen',/,
1 1X,T2,' ',
1 'H : ',F11.2,' m , Meridiankonvergenz : ',F5.2,' gon',/,
1 1X,T2,' ',
C 1 'Z : ',F11.2,' m (ueber NN)')
1 'Z : ',F11.2,' m (bzgl. NN)')
DECL = DECL/DEGRAD/.9
ENCODE (5,'(F5.1)',C_REMARK(1:5)) DECL
C_REMARK =
1 'Missweisung zw. geogr. und magn. Nord : '//C_REMARK(1:5)//' gon'
WRITE (OUTPUT,82) C_REMARK
82 FORMAT
1 (1X,T2,' ',A58,/)
ROW_COUNTER = ROW_COUNTER + 5
END IF
WRITE(*,1100) 'DATUM DES MESS. ? '
READ (*,'(A58)') C_DATUM
WRITE (OUTPUT,9) C_DATUM
DATE = C_DATUM (1:40)
9 FORMAT (1X,T2,'Datum der Messung : ',A58,/)
WRITE(*,1100) 'MESSTRUPP ? '
READ (*,'(A58)') C_MESSTRUPP
WRITE (OUTPUT,11) C_MESSTRUPP
11 FORMAT (1X,T2,'Messtrupp : ',A58,/)
C HIER SOLLTE EIGENTLICH DER SONDENTYP AUS TOOLTYPE.DAT HERAUSGEZOGEN WERDEN..
IF (TYPE_OF_TOOL .EQ. 4.0)
1C_SONDE =
1'Eastman Multishot DX , 90 Grad Vertikalpendeleinsatz'
IF (TYPE_OF_TOOL .EQ. 4.1)
1C_SONDE =
1'Eastman Multishot DX , 30 Grad Horizontalpendeleinsatz'
IF (TYPE_OF_TOOL .EQ. 4.2)
1C_SONDE =
1'Eastman Multishot DX , 17 Grad Vertikalpendeleinsatz'
IF (TYPE_OF_TOOL .EQ. 4.3)
1C_SONDE =
1'Eastman Multishot DX , 5 Grad Vertikalpendeleinsatz'
D TYPE *,'TYPE_OF_TOOL :',C_SONDE
WRITE (OUTPUT,15) C_SONDE
15 FORMAT (1X,T2,'Sondentypen : ',A58,/)
WRITE(*,*) ' 1.SONDENTYP : ',C_SONDE
WRITE(*,1100) '2.SONDENTYP ? '
READ (*,'(A58)') C_SONDE
WRITE (OUTPUT,155) C_SONDE
155 FORMAT (1X,T2,' ',A58,/)
IF (SE_FHMOD(1:9) .EQ. 'DR_TANMET')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_CL ,Tangenten Methode'
IF (SE_FHMOD(1:9) .EQ. 'DR_BATAME')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_CL ,Balanced Tangential Method'
IF (SE_FHMOD(1:9) .EQ. 'DR_ANGAVE')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_CL ,Angle-averaging Methode'
IF (SE_FHMOD(1:9) .EQ. 'DR_RADIOC')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_CL ,Radius of curvature Methode'
WRITE (OUTPUT,14) C_DATENBEARBEITUNG
14 FORMAT (1X,T2,'Datenbearbeitung : ',A58,/)
WRITE(*,*) 'DATENBEARB.VERLAUF: ',C_DATENBEARBEITUNG
WRITE(*,1100) 'DATENBEARB. 2.TOOL ? '
READ (*,'(A58)') C_DATENBEARBEITUNG
WRITE (OUTPUT,144) C_DATENBEARBEITUNG
144 FORMAT (1X,T2,' ',A58,/)
WRITE(*,1100) 'AUSWERTER ? '
READ (*,'(A58)') C_AUSWERTER
WRITE (OUTPUT,13) C_AUSWERTER
13 FORMAT (1X,T2,'Auswerter : ',A58,/)
IF (.NOT.L_REF) THEN
ENCODE (5,'(F5.1)',C_REMARK(1:5)) DECL
C_REMARK =
1 'Missweisung zw. geogr. und magn. Nord : '//C_REMARK(1:5)//' gon'
WRITE (OUTPUT,16) C_REMARK
END IF
WRITE(*,1100) 'BEMERKUNGEN : '
READ (*,'(A58)') C_REMARK
IF (.NOT.L_REF) WRITE (OUTPUT,116) C_REMARK
IF (L_REF) WRITE (OUTPUT,16) C_REMARK
16 FORMAT (1X,T2,'Bemerkungen : ',A58,//)
116 FORMAT (1X,T2,' ',A58,//)
1116 CONTINUE
WRITE (*,1100) 'WEITERE BEMER.(J/N)?'
READ (*,'(A1)') ANSWER
IF (ANSWER.EQ. 'J') THEN
ROW_COUNTER = ROW_COUNTER + 1
WRITE(*,1100) 'BEMERKUNGEN : '
READ (*,'(A58)') C_REMARK
WRITE (OUTPUT,116) C_REMARK
GOTO 1116
END IF
ROW_COUNTER = ROW_COUNTER + 28
C-------GEBE LISTENKOPF AUS:
CALL PR_CL_SCHEDHEAD (RET_STAT,OUTPUT,ROW_COUNTER,L_REF)
C-------LESE EIN BIS EOF:
DO WHILE (IOERR .EQ. 0)
IF (ROW_COUNTER .GT. 60) THEN !TOP OF FORM
ROW_COUNTER = 0
CALL PR_CL_NEWPAGE
1 (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
END IF
IF (L_REF) THEN !GAUSS-KRUEGER OUT-PUT
READ (UNIT_NO3,IOSTAT=IOERR)
1 LAYER,DESDEP_B,DESDEP_E,
1 R1,ERR_LX1,H1,ERR_LY1,ZNN1,ERR_LZ1,
1 R2,ERR_LY2,H2,ERR_LY2,ZNN2,ERR_LZ2
IF (IOERR .EQ. 0) THEN
D WRITE(*,*) LAYER,DESDEP_B,DESDEP_E
D WRITE(*,*) R1,H1,ZNN1
D WRITE(*,*) R2,H2,ZNN2
WRITE(OUTPUT,100) LAYER,DESDEP_B,R1,H1,ZNN1,
1 DESDEP_E,R2,H2,ZNN2
END IF
100 FORMAT (/,1X,T3,A15, T25,F7.1,
1 T36,F11.1, T50,F11.1, T61,F11.1,/,1X,
1 T25,F7.1, T36,F11.1, T50,F11.1, T61,F11.1)
ELSE
READ (UNIT_NO3,IOSTAT=IOERR)
1 LAYER,DESDEP_B,DESDEP_E,
1 LX1,ERR_LX1,LY1,ERR_LY1,LZ1,ERR_LZ1,
1 LX2,ERR_LX2,LY2,ERR_LY2,LZ2,ERR_LZ2
IF (IOERR .EQ. 0) THEN
D WRITE(*,*) LAYER,DESDEP_B,DESDEP_E
D WRITE(*,*) LY1,LX1,LZ1
D WRITE(*,*) LY2,LX2,LZ2
WRITE(OUTPUT,200) LAYER,DESDEP_B,LZ1,LY1,LX1,
1 DESDEP_E,LZ2,LY2,LX2
END IF
200 FORMAT (/,1X,T3,A15, T25,F7.1,
1 T36,F7.1, T50,F11.1, T61,F11.1,/,1X,
1 T25,F7.1, T36,F7.1, T50,F11.1, T61,F11.1)
END IF
ROW_COUNTER = ROW_COUNTER + 3
END DO !WHILE
RETURN
1100 FORMAT (1X,A20,$)
END
CBCB
C INCLUDE FILE DR_DECL.FOR
C FORMAT-DECLARATIONS FOR DTV-FILE :
C DR$X_SIZE
C DR$Y_SIZE
C OFFSETS FOR INPUT-DATA :
C NOTE THAT THIS OFFSETS BEGINS WITH 1 , NOT 0 ! (THERE ARE 'HISTORICAL REASONS.....)
C 1 TYPE OF TOOL (SEE TOOLTYPE.DAT)
C 2 DECLINATION OF MAGNETIC FIELD IN DEGREES
C 3 ERROR DECLINATION OF MAGNETIC FIELD IN DEGREES
C 4 INCLINATION OF MAGNETIC FIELD IN DEGREES
C 5 ERROR INCLINATION OF MAGNETIC FIELD IN DEGREES
C 6 TOTAL INTENSITY OF MAGNETIC FIELD IN nT (NANO TESLA)
C 7 ERROR TOTAL INTENSITY OF MAGNETIC FIELD IN nT (NANO TESLA)
C 8 MEASURED DEPTH IN METERS
C 9 TIME IN SECONDS
C 10 TEMPERATURE INSIDE
C 11 FLUX INTENSITY OR FLUX Z OR AZIMUT
C 12 NORTH-POINTER OR FLUX Y
C 13 FLUX X
C 14 Z-ACCELEROMETER OR Z GEOPHONE OR DIP
C 15 Y-ACCELEROMETER OR Y-INCLINOMETER
C 16 X-ACCELEROMETER OR X-INCLINOMETER
C OFFSETS FOR OUTPUT-DATA :
C 17 DEPTH
C 18 ERROR DEPTH
C 19 ERROR TIME
C 20 TEMPERATURE CALIBRATED
C 21 FLUX Z CALIBRATED
C 22 ERROR FLUX Z CALIBRATED
C 23 FLUX Y CALIBRATED
C 24 ERROR FLUX Y CALIBRATED
C 25 FLUX X CALIBRATED
C 26 ERROR FLUX X CALIBRATED
C 27 FLUX INTENSITY CALIBRATED
C 28 ERROR FLUX INTENSITY CALIBRATED
C 29 NORTH-POINTER CALIBRATED
C 30 ERROR NORTH-POINTER CALIBRATED
C 31 Z-ACCEL. CALIBRATE
C 32 ERROR Z-ACCEL. CALIBRATED
C 33 Y-ACCEL. CALIBRATED
C 34 ERROR Y-ACCEL. CALIBRATED
C 35 X-ACCEL. CALIBRATED
C 36 ERROR X-ACCEL. CALIBRATED
C 37 Z-GEOPHONE CALIBRATED
C 38 ERROR Z-GEOPHONE CALIBRATED
C 39 Y-INCLINOMETER CALIBRATED
C 40 ERROR Y-INCLINOMETER CALIBRATED
C 41 X-INCLINOMETER CALIBRATED
C 42 ERROR X-INCLINOMETER CALIBRATED
C 43 DIP IN RADIAN
C 44 ERROR DIP IN RADIAN
C 45 AZIMUT OF TOOL IN RADIAN
C 46 ERROR AZIMUT OF TOOL IN RADIAN
C 47 RELATIVE BEARING IN RADIAN
C 48 ERROR RELATIVE BEARING IN RADIAN
C 49 AZIMUT OF HOLE DEVIATION IN RADIAN
C 50 ERROR AZIMUT OF HOLE DEVIATION IN RADIAN
C 51 MOST SIGNIFICANT Z-COORDINATE IN METERS
C 52 LESS SIGNIFICANT Z-COORDINATE IN METERS
C 53 ERROR Z-COORDINATE IN METERS
C 54 MOST SIGNIFICANT Y-COORDINATE IN METERS
C 55 LESS SIGNIFICANT Y-COORDINATE IN METERS
C 56 ERROR Y-COORDINATE IN METERS
C 57 MOST SIGNIFICANT X-COORDINATE IN METERS
C 58 LESS SIGNIFICANT X-COORDINATE IN METERS
C 59 ERROR X-COORDINATE IN METERS
C BEGIN:
C-------DECLARATION:
REAL
1 PI,
1 PI2,
1 DEGRAD !DEGREES TO RADIAN
PARAMETER (PI = 3.141593,
1 PI2 = PI/2.,
1 DEGRAD = PI/180.)
DOUBLE PRECISION
1 DPI,
1 DPI2,
1 DDEGRAD !DEGREES TO RADIAN
PARAMETER (DPI=3.141592653589793,
1 DPI2=DPI/2.,
1 DDEGRAD = DPI/180.)
INTEGER
1 DR$X_SIZE,
1 DR$Y_SIZE
REAL
1 TYPE_OF_TOOL, !(SEE TOOLTYPE.DAT)
1 MAGDECL, !DECLINATION OF MAGNETIC FIELD IN DEGREES
2 ERR_MAGDECL, !IN DEGREES
3 MAGINCL, ! INCLINATION OF MAGNETIC FIELD IN DEGREES
4 ERR_MAGINCL, !IN DEGREES
5 MAGINT, !INTENSITY OF MAGNETIC FIELD IN nT (NANO TESLA)
6 ERR_MAGINT, !IN nT
1 M_DEPTH, !MEASURED IN METERS
2 TIME , !IN SECONDS
3 TEMPERATURE, !INSIDE
4 FLUX_INTENSITY,
1 FLUX_Z,
1 MEAS_AZI, !MEASURED AZIMUT (E.G. MULTISHOT)
5 NORTH_POINTER,
1 FLUX_Y,
6 FLUX_X,
7 Z_ACCEL,
1 Z_GEOPHONE,
1 MEAS_DIP, !MEASURED DIP (E.G. MULTISHOT)
8 Y_ACCEL,
1 Y_INCL,
9 X_ACCEL,
1 X_INCL,
1 DEPTH, !IN METERS
1 ERR_DEPTH,
2 ERR_TIME,
3 TEMPERATURE_CAL,
4 FLUX_Z_CAL,
5 ERR_FLUX_Z_CAL,
6 FLUX_Y_CAL,
7 ERR_FLUX_Y_CAL,
8 FLUX_X_CAL,
9 ERR_FLUX_X_CAL,
1 FLUX_INTENSITY_CAL,
1 ERR_FLUX_INTENSITY_CAL,
2 NORTH_POINTER_CAL,
3 ERR_NORTH_POINTER_CAL,
4 Z_ACCEL_CAL,
5 ERR_Z_ACCEL_CAL,
6 Y_ACCEL_CAL,
7 ERR_Y_ACCEL_CAL,
8 X_ACCEL_CAL,
9 ERR_X_ACCEL_CAL,
1 Z_GEOPHONE_CAL,
1 ERR_Z_GEOPHONE_CAL,
2 Y_INCL_CAL,
3 ERR_Y_INCL_CAL,
4 X_INCL_CAL,
5 ERR_X_INCL_CAL,
6 DIP, ! IN RADIAN
7 ERR_DIP, !IN RADIAN
8 AZI , !AZIMUT OF TOOL IN RADIAN
9 ERR_AZI,
1 RB, !RELATIVE BEARING IN RADIAN
1 ERR_RB,
2 AHD, !AZIMUT OF HOLE DEVIATION IN RADIAN
3 ERR_AHD, !ERROR AZIMUT OF HOLE DEVIATION IN RADIAN
4 MSZ, !MOST SIGNIFICANT Z-COORDINATE IN METERS
4 LSZ, !LESS SIGNIFICANT Z-COORDINATE IN METERS
5 ERR_Z ,
4 MSY, !MOST SIGNIFICANT NORTH-SOUTH-COORDINATE IN METERS
4 LSY, !LESS SIGNIFICANT NORTH-SOUTH-COORDINATE IN METERS
7 ERR_Y,
4 MSX, !MOST SIGNIFICANT EAST-WEST-COORDINATE IN METERS
4 LSX, !LESS SIGNIFICANT EAST-WEST-COORDINATE IN METERS
9 ERR_X
INTEGER !POINTER
1 P_TYPE_OF_TOOL ,
1 P_MAGDECL,
2 P_ERR_MAGDECL,
3 P_MAGINCL,
4 P_ERR_MAGINCL,
5 P_MAGINT,
6 P_ERR_MAGINT,
1 P_M_DEPTH ,
2 P_TIME ,
3 P_TEMPERATURE ,
4 P_FLUX_INTENSITY ,
1 P_FLUX_Z ,
1 P_MEAS_AZI,
5 P_NORTH_POINTER ,
1 P_FLUX_Y ,
6 P_FLUX_X ,
7 P_Z_ACCEL ,
1 P_Z_GEOPHONE ,
1 P_MEAS_DIP,
8 P_Y_ACCEL ,
1 P_Y_INCL ,
9 P_X_ACCEL ,
1 P_X_INCL ,
1 P_DEPTH ,
1 P_ERR_DEPTH ,
2 P_ERR_TIME ,
3 P_TEMPERATURE_CAL ,
4 P_FLUX_Z_CAL ,
5 P_ERR_FLUX_Z_CAL ,
6 P_FLUX_Y_CAL ,
7 P_ERR_FLUX_Y_CAL ,
8 P_FLUX_X_CAL ,
9 P_ERR_FLUX_X_CAL ,
1 P_FLUX_INTENSITY_CAL ,
1 P_ERR_FLUX_INTENSITY_CAL,
2 P_NORTH_POINTER_CAL ,
3 P_ERR_NORTH_POINTER_CAL ,
4 P_Z_ACCEL_CAL ,
5 P_ERR_Z_ACCEL_CAL ,
6 P_Y_ACCEL_CAL ,
7 P_ERR_Y_ACCEL_CAL ,
8 P_X_ACCEL_CAL ,
9 P_ERR_X_ACCEL_CAL ,
1 P_Z_GEOPHONE_CAL ,
1 P_ERR_Z_GEOPHONE_CAL ,
2 P_Y_INCL_CAL ,
3 P_ERR_Y_INCL_CAL ,
4 P_X_INCL_CAL ,
5 P_ERR_X_INCL_CAL ,
6 P_DIP ,
7 P_ERR_DIP ,
8 P_AZI ,
9 P_ERR_AZI ,
1 P_RB ,
1 P_ERR_RB ,
2 P_AHD ,
3 P_ERR_AHD ,
4 P_MSZ ,
4 P_LSZ ,
5 P_ERR_Z ,
6 P_MSY ,
6 P_LSY ,
7 P_ERR_Y ,
8 P_MSX ,
8 P_LSX ,
9 P_ERR_X
PARAMETER
1 (DR$X_SIZE = 64,
1 DR$Y_SIZE = 64)
PARAMETER !POINTER
1 (P_TYPE_OF_TOOL = 1,
1 P_MAGDECL = 2,
2 P_ERR_MAGDECL = 3,
3 P_MAGINCL = 4,
4 P_ERR_MAGINCL = 5,
5 P_MAGINT = 6,
6 P_ERR_MAGINT = 7,
1 P_M_DEPTH = 8,
2 P_TIME = 9,
3 P_TEMPERATURE = 10,
4 P_FLUX_INTENSITY = 11,
1 P_FLUX_Z = 11,
1 P_MEAS_AZI = 11,
5 P_NORTH_POINTER = 12,
1 P_FLUX_Y = 12,
6 P_FLUX_X = 13,
7 P_Z_ACCEL = 14,
1 P_Z_GEOPHONE = 14,
1 P_MEAS_DIP = 14,
8 P_Y_ACCEL = 15,
1 P_Y_INCL = 15,
9 P_X_ACCEL = 16,
1 P_X_INCL = 16,
1 P_DEPTH = 17,
1 P_ERR_DEPTH = 18,
2 P_ERR_TIME = 19,
3 P_TEMPERATURE_CAL = 20,
4 P_FLUX_Z_CAL = 21,
5 P_ERR_FLUX_Z_CAL = 22,
6 P_FLUX_Y_CAL = 23,
7 P_ERR_FLUX_Y_CAL = 24,
8 P_FLUX_X_CAL = 25,
9 P_ERR_FLUX_X_CAL = 26,
1 P_FLUX_INTENSITY_CAL = 27,
1 P_ERR_FLUX_INTENSITY_CAL= 28,
2 P_NORTH_POINTER_CAL = 29,
3 P_ERR_NORTH_POINTER_CAL = 30,
4 P_Z_ACCEL_CAL = 31,
5 P_ERR_Z_ACCEL_CAL = 32,
6 P_Y_ACCEL_CAL = 33,
7 P_ERR_Y_ACCEL_CAL = 34,
8 P_X_ACCEL_CAL = 35,
9 P_ERR_X_ACCEL_CAL = 36,
1 P_Z_GEOPHONE_CAL = 37,
1 P_ERR_Z_GEOPHONE_CAL = 38,
2 P_Y_INCL_CAL = 39,
3 P_ERR_Y_INCL_CAL = 40,
4 P_X_INCL_CAL = 41,
5 P_ERR_X_INCL_CAL = 42,
6 P_DIP = 43,
7 P_ERR_DIP = 44,
8 P_AZI = 45,
9 P_ERR_AZI = 46,
1 P_RB = 47,
1 P_ERR_RB = 48,
2 P_AHD = 49,
3 P_ERR_AHD = 50,
4 P_MSZ = 51,
4 P_LSZ = 52,
5 P_ERR_Z = 53 ,
6 P_MSY = 54,
6 P_LSY = 55,
7 P_ERR_Y = 56,
8 P_MSX = 57 ,
8 P_LSX = 58 ,
9 P_ERR_X = 59 )
C END;
PROGRAM DTV_CL
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE COORDINATES OF SPECIFIED LAYERS. THE COORDINATES
C FROM DEVIATIONLOG ARE STORED IN A DTV-FILE WITH DATA-KIND 12 AND DR-DECL-FORMAT.
C FLOWCHART: 1. READ LOGGING DEPTH FROM DIRECTIONAL SURVEY
C 2. INPUT NAMES OF LAYERS AND MEASURED DEPTHS (CABLE_LEN)
C 3. COMPUTE COORDINATES OF MEASURED DEPTH
C 4. CREATE SCHEDULE
C 5. EXIT
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !!
C INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
INCLUDE 'DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(COM_FBLK)'
INCLUDE '(LOC_FSH)'
INTEGER
1 UNIT_NO1,
1 UNIT_NO2,
1 UNIT_NO3,
5 RET_STAT
LOGICAL L_DIRECTION, !.T IF LOGGING DIRECTION FROM BOTTOM TO TOP
1 L_TANMET, !
1 L_BATAME,
1 L_ANGAVE,
1 L_RADIOC,
1 L_FR,
1 L_ERROR,
1 L_WRONGDEPTH,
1 L_AZI,
1 L_REF,
1 L_DEC
CHARACTER*1
1 ANSWER
CHARACTER*60 FILE_NAME
CHARACTER*30 LAY_FIL_NAM
CHARACTER*9 EXECUTIVE
CHARACTER*3 TOOL
CHARACTER*(FSH$FHMOD_L) SE_FHMOD !NAME OF EXECUTED MODULE
CHARACTER*(FSH$FHPAR_L) SE_FHPAR !NAME OF PARAMETERFILE OF MODUL
CHARACTER*(FSH$FHEXE_L) SE_FHEXE !NAME OF THE EXECUTIVE
CHARACTER*(FSH$FHDAT_L) SE_FHDAT !DATE OF MODUL EXECUTION
CHARACTER*(FSH$DFRE_L) SE_DFRE
INTEGER*2 GBVAL_I2(2)
INTEGER
* DATA_KIND,
* DIB, !DEPTH INTERVAL BEGIN
* DIE, !DEPTH INTERVAL END
* DI_ECNT, !DEPTH INTERVAL SEG. ENTRY COUNT
* DF_ECNT, !DATA FORMAT SEGMENT ENRTY COUNT
* FH_ECNT,
* ENTRY_NO, !ENTRY NUMBER DATV_RDWC
* FBLK_NO, !FILEBLOCK NUMBER
* B_NEXT, !PREVIOUS FILEBLOCK OF SAME DATA KIND
* F_NEXT, !NEXT FILEBLOCK OF SAME DATA KIND
* GBVAL_I4(5), !(1)=DATA_KIND
C * !(2)=DATA LENGTH IN BYTES
C * !(3)=BACKWARD REF. TO PREVIOUS FBLK
C * !(4)=FORWARD REF. TO NEXT FBLK
C * !(5)=DEPTH IN MM OF FIRST REVOL. IN FBLK
* GHFLID, !FILE IDENTIFICATION NUMBER
* GHNOBLKS, !NUMBER OF LAST FILE BLOCK
* SE_DFFREF, !S.E.F.:FIRST LIST ELEMENT OF SPEC. DATA KIND
* SE_DFKI, !SEG. ENTRY FIELD : KIND OF DATA
* SE_DFLEC,
* SE_DFLREF, !S.E.F.:LAST LIST ELEMENT OF SPEC. DATA KIND
* SE_DFXS, !X-SIZE
* SE_DFYS, !Y-SIZE
* SE_DFZS,
* SE_DIBNB, !SEGMENT ENTRY FIELD FILEBLOCK BEGIN
* SE_DIBNE, !SEGMENT ENTRY FIELD FILEBLOCK END
* SE_DIB, !SEG. ENTRY FIELD: DEPTH AT THE BEGIN
* SE_DIE, !SEG. ENTRY FIELD: DEPTH AT THE END
* SE_FHBB,
* SE_FHBE
REAL GBVAL_R4(5),
* GHSCALE, !DATA SCALE FACTOR
* SE_DFMIN, !MINIMUM LIMIT OF DATA
* SE_DFMAX, !MAXIMUM LIMIT OF DATA
1 R_DIB,
1 R_DIE,
1 MEDI !MERIDIANKONVERGENZ IN RAD
INTEGER KEZI !KENNZIFFER DES STREIFENS
DOUBLE PRECISION !STARTCOORDINATES
1 R,
1 H,
1 ZNN
C.......VARIABLENNAMEN VON COMMAND_PROCEDURE :
CHARACTER*60 C_INPUT_NAME !DTV_FILE_NAME
CHARACTER*1 C_AZI !J/N
CHARACTER*1 C_REF !J/N .TRUE. IF GAUSS-KRUEGER OUTPUT
CHARACTER*1 C_DUM
CHARACTER*1 C_DEC
CHARACTER*30 DATADIR
CHARACTER*30 PRINTDIR
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'PROGRAM "DTV_CL". JP MAR.88'
WRITE(*,*)
C LESE PARAMETER_FILE:
L_AZI = .TRUE.
L_REF = .TRUE.
L_DEC = .TRUE.
OPEN (UNIT=36,FILE='PARAMETER',
1 STATUS='OLD')
READ (36,'(A30)') FILE_NAME
READ (36,'(A1)') C_AZI
READ (36,'(A3)') TOOL
READ (36,'(A1)') C_REF
READ (36,'(A1)') C_DEC
READ (36,'(A30)') DATADIR
READ (36,'(A30)') PRINTDIR
CLOSE (36,STATUS='KEEP')
IF (C_AZI .EQ. 'N') L_AZI = .FALSE.
DECODE (3,'(F3.1)',TOOL) TYPE_OF_TOOL
IF (C_REF .EQ. 'N') L_REF = .FALSE.
IF (C_DEC .EQ. 'N') L_DEC = .FALSE.
D TYPE *,'FILE_NAME :',FILE_NAME
D TYPE *,'C_AZI :',C_AZI,L_AZI
D TYPE *,'TYPE_OF_TOOL :',TOOL,TYPE_OF_TOOL
D TYPE *,'C_REF :',C_REF,L_REF
D TYPE *,'C_DEC :',C_DEC,L_DEC
C <TESTE ERSTMAL OB ES UEBERHAUPT GEHT MIT DEM DATENFILE..>
D TYPE*,'CHECK AZI T/F..'
IF (.NOT.L_AZI) THEN
L_ERROR = .TRUE.
GOTO 9999
ELSE IF (.NOT.L_DEC) THEN
L_ERROR = .TRUE.
GOTO 9999
END IF
1 CONTINUE
CALL LIB$GET_LUN(UNIT_NO1)
CALL LIB$GET_LUN(UNIT_NO2)
CALL LIB$GET_LUN(UNIT_NO3)
IF (UNIT_NO1 .LT. 7 .OR. UNIT_NO2 .LT. 7 .OR. UNIT_NO3 .LT. 7) THEN
WRITE(*,*)'ERROR WITH UNIT NUMBER :',UNIT_NO1, UNIT_NO2
PAUSE 'TYPE CONTINUE OR EXIT'
GOTO 1
END IF
CALL DATV_OPRO (UNIT_NO1,FILE_NAME,'OLD',RET_STAT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_OPRO')
FBLK_NO = 1
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
CALL FSHEC_SERV (DI_ECNT,DF_ECNT,FH_ECNT)
DO ENTRY_NO = 1 , DI_ECNT
CALL FSHDI_SEG ('READ',RET_STAT,ENTRY_NO,
* SE_DIB,SE_DIBNB,SE_DIE,SE_DIBNE)
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHDI_SEG')
C_________STELLE DIE LOGGING DIRECTION FEST :
IF (SE_DIB .GT. SE_DIE) THEN
L_DIRECTION = .TRUE.
ELSE
L_DIRECTION = .FALSE.
END IF
END DO
R_DIB = FLOAT(DIB)/1000.
R_DIE = FLOAT(DIE)/1000.
WRITE (*,112) 'DEPTH INTERVAL BEGIN : ',R_DIB,' m'
WRITE (*,112) 'DEPTH INTERVAL END : ',R_DIE,' m'
112 FORMAT (1X,A30,F9.3,A2)
WRITE (*,113) 'THAT''S RIGTH (DEF=Y/N) ? '
113 FORMAT (1X,A30,$)
READ (*,'(A1)') ANSWER
CALL LOGICAL_C_IN_YDEF (RET_STAT,L_WRONGDEPTH,ANSWER)
IF (.NOT.L_WRONGDEPTH) THEN
WRITE(*,*) 'S... - WAIT A MOMENT, SEARCH RIGHT DEPTH....'
CALL SEARCH_DEPTH(UNIT_NO1,SE_DIBNB,SE_DIBNE,R_DIB,R_DIE)
FBLK_NO = 1
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
WRITE (*,112) 'DEPTH INTERVAL BEGIN : ',R_DIB,' m'
WRITE (*,112) 'DEPTH INTERVAL END : ',R_DIE,' m'
WRITE (*,113) 'THAT''S RIGTH (DEF=Y/N) ? '
READ (*,'(A1)') ANSWER
CALL LOGICAL_C_IN_YDEF (RET_STAT,L_WRONGDEPTH,ANSWER)
IF (.NOT.L_WRONGDEPTH) THEN
L_ERROR =.TRUE.
GOTO 9999
END IF
END IF
DO ENTRY_NO = 1 , DF_ECNT
CALL FSHDF_SEG ('READ',RET_STAT,ENTRY_NO,
* SE_DFKI,SE_DFXS,SE_DFYS,SE_DFZS,
* SE_DFLEC,SE_DFFREF,SE_DFLREF,
* SE_DFMIN,SE_DFMAX,SE_DFRE)
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHDF_SERV')
END DO
D TYPE *,'CHECK DATA-KIND..'
IF (SE_DFKI .NE. 12) THEN
CALL RETSTAT (RET_STAT,'WRONG DATA-KIND')
L_ERROR = .TRUE.
GOTO 9999
END IF
DO ENTRY_NO = 1 , FH_ECNT
CALL FSHFH_SEG ('READ',RET_STAT,ENTRY_NO,SE_FHMOD,
* SE_FHPAR, SE_FHEXE,SE_FHDAT,
* SE_FHBB,SE_FHBE)
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHFH_SERV')
C WRITE(6,220)SE_FHMOD
END DO
D TYPE *,'CHECK PREVIOUS MANIPULATION..'
L_TANMET = .FALSE.
L_BATAME = .FALSE.
L_ANGAVE = .FALSE.
L_RADIOC = .FALSE.
IF (SE_FHMOD(1:3) .EQ. 'DR_') THEN
IF (SE_FHMOD .EQ. 'DR_TANMET') THEN
L_TANMET = .TRUE.
ELSE IF (SE_FHMOD .EQ. 'DR_BATAME') THEN
L_BATAME = .TRUE.
ELSE IF (SE_FHMOD .EQ. 'DR_ANGAVE') THEN
L_ANGAVE = .TRUE.
ELSE IF (SE_FHMOD .EQ. 'DR_RADIOC') THEN
L_RADIOC = .TRUE.
ELSE
L_ERROR = .TRUE.
GOTO 9999
END IF
ELSE
L_ERROR = .TRUE.
GOTO 9999
END IF
IF (L_REF) THEN !<ENTER TIE-IN-COORDINATES>
WRITE(*,*)
1 'ENTER STARTCOORDINATES CORRESPONDING TO GAUSS-KRUEGER SYSTEM :'
WRITE(*,1100) 'RECHTSWERT ? '
READ (*,*) R
WRITE(*,1100) 'HOCHWERT ? '
READ (*,*) H
WRITE(*,1100) 'HEIGHT Z ABOVE SEA LEVEL ? '
READ (*,*) ZNN
WRITE(*,1101) ' '
READ (*,*) KEZI
C <RECHNE MERIDIANKONVERGENZ AUS :>
CALL MK (MEDI,R,H,KEZI)
D TYPE *,'MERIDIANKONVERGENZ IN ALTGRAD : ',MEDI
MEDI = MEDI * DEGRAD
1100 FORMAT (1X,A30,$)
1101 FORMAT(1X,'ENTER MERIDIAN-STRIPE-CONSTANT (ALMOST ALWAYS THE ',
1'FIRST RECHTSWERT DIGIT) ? ',/,1X,A30,$)
END IF
C <LESE DIE SCHICHTNAMEN UND KABELLAENGEN EIN>
LAY_FIL_NAM = 'LAY_'//FILE_NAME(1:INDEX(FILE_NAME,' '))
D TYPE *,'LAYFILNAM :',LAY_FIL_NAM
OPEN (UNIT=UNIT_NO2,FILE=LAY_FIL_NAM//'.DAT',
1 STATUS='NEW',DEFAULTFILE=DATADIR,ACCESS='SEQUENTIAL',
1 FORM='UNFORMATTED')
CALL LAYER_IN
1 (RET_STAT,UNIT_NO2,R_DIB,R_DIE,LAY_FIL_NAM,DATADIR)
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'LAYER_IN')
REWIND (UNIT_NO2)
C <RECHNE DIE KOORDINATEN ZU DEN SCHICHTEN>
OPEN (UNIT=UNIT_NO3,FILE=LAY_FIL_NAM//'.DAT',
1 STATUS='NEW',DEFAULTFILE=DATADIR,ACCESS='SEQUENTIAL',
1 FORM='UNFORMATTED')
CALL COMP_LA_COOR
1 (RET_STAT,UNIT_NO1,UNIT_NO2,UNIT_NO3,
1 R_DIB,R_DIE,SE_DIBNB,SE_DIBNE,
1 L_REF,L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,MEDI,R,H,ZNN)
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'COMP_LA_COR')
CLOSE (UNIT_NO2,STATUS='DELETE')
REWIND (UNIT_NO3)
C <GEBE LISTE RAUS>
OPEN (UNIT=UNIT_NO2,FILE='DTV_CL_LIST.DAT',
1 STATUS='NEW',DEFAULTFILE=PRINTDIR,ACCESS='SEQUENTIAL',
1 CARRIAGECONTROL='LIST')
FBLK_NO = SE_DIBNB
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
MAGDECL = FB_DATA (P_MAGDECL)
CALL CREA_CL_LIST
1 (RET_STAT,UNIT_NO3,UNIT_NO2,
1 L_REF,L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,SE_FHMOD,SE_FHEXE,
1 KEZI,MEDI,MAGDECL,R_DIE,R,H,ZNN)
CLOSE (UNIT_NO2,STATUS='KEEP')
CLOSE (UNIT_NO3,STATUS='KEEP')
9999 CONTINUE
IF (L_ERROR) THEN
TYPE *,'*******SO GEHT"S NICHT !!! ----> EXIT'
END IF
CALL LIB$FREE_LUN(UNIT_NO1)
CALL LIB$FREE_LUN(UNIT_NO2)
CALL LIB$FREE_LUN(UNIT_NO3)
END
CZ
SUBROUTINE EXT_2RIDP (DX,MSX,LSX)
C This subroutine EXTracts from 2 Real values a Double Precision value .
C JP MAR88
IMPLICIT NONE !
DOUBLE PRECISION DX
REAL MSX,LSX
C BEGIN:
DX = DBLE(MSX) + DBLE(LSX)
D WRITE(*,*) 'MSX :',MSX
D WRITE(*,*) 'LSX :',LSX
D WRITE(*,*) 'DX :',DX
C END;
RETURN
END
SUBROUTINE EXT_VALUES
1 (RET_STAT,STRING,NAME,R1,R2)
C THIS PROGRAM EXTRACTS THREE VALUES ,A STRING(NAME) AND TWO REALNUMBERS, FROM
C THE INPUT-STRNG STRING !
C THERE'S A TEST-PROGRAM : T_EXT-VALUES.EXE
C JP MAR 88
IMPLICIT NONE !
CHARACTER*(*) STRING
CHARACTER*(*) NAME
REAL R1,
1 R2
INTEGER LSB,
1 MSB,
1 I,
1 RET_STAT
C BEGIN:
I = LEN (STRING)
DO WHILE (STRING(I:I) .EQ. ' ' .AND. I .GT. 0)
I = I - 1
END DO !WHILE
LSB = I+1
DO WHILE (STRING(I:I) .NE. ' ' .AND. I .GT. 0)
I = I - 1
END DO !WHILE
MSB = I+1
D TYPE *,'MSB,LSB R2:',MSB,LSB
DECODE (8,'(F<LSB-MSB>.0)',STRING(MSB:LSB),ERR=99) R2
DO WHILE (STRING(I:I) .EQ. ' ' .AND. I .GT. 0)
I = I - 1
END DO !WHILE
LSB = I+1
DO WHILE (STRING(I:I) .NE. ' ' .AND. I .GT. 0)
I = I - 1
END DO !WHILE
MSB = I+1
D TYPE *,'MSB,LSB R1:',MSB,LSB
DECODE (8,'(F<LSB-MSB>.0)',STRING(MSB:LSB),ERR=99) R1
C 1 = 1 !HA!
I = 1
C DO WHILE (STRING(I:I) .NE. ' ' .AND. I .LT. MSB .AND. I .LT. LEN(NAME))
DO WHILE (I .LT. MSB .AND. I .LT. LEN(NAME))
I = I + 1
END DO !WHILE
IF (I .EQ. MSB) I = MSB-1
NAME = STRING(1:I)
C END;
RETURN
C99 PAUSE 'SORRY, CANNOT DECODE YOU INPUT......'
99 RET_STAT = 99
RETURN
END
SUBROUTINE LAYER_IN
1 (RET_STAT,UNIT_NO2,R_DIB,R_DIE,LAY_FIL_NAM,DATADIR)
C THIS SUBROUTINE IS USED FOR INPUT OF LAYER NAMES AND CABLE LENGTHS.
C JP MAR 88
C SIMPLIFIED VERSION....
IMPLICIT NONE !
INTEGER RET_STAT,
1 UNIT_NO2
C 1 DIB, !LOGGING INTERVAL BEGIN OF DIRECTIONAL SURVEY
C 1 DIE !LOGGING INTERVAL END OF DIRECTIONAL SURVEY
CHARACTER*1 ANSWER,
1 C_DUM
C CHARACTER*8 BUFFER
CHARACTER*15 LAY_NA !NAME OF LAYER
CHARACTER*30 LAY_FIL_NAM, !FILENAME OF LAYER-DATA
1 DATADIR
CHARACTER*80 STRING
REAL LAY_BE, !CABLE LENGTH TO LAYERBEGIN
1 LAY_EN, !CABLE LENGTH TO LAYEREND
1 R_DIB,
1 R_DIE
LOGICAL L_FR
C BEGIN:
L_FR = .TRUE.
WRITE (*,1) 'SUBPROGRAM LAYER_IN JP MAR88'
1 FORMAT (//,1X,A50,//,1X,
1'This program asks for - layer names (up to 15 characters)',
1/,1x,
1' - measured cable length the ',
1'layer appears ',/,1x,
1' - measured cable length the ',
1'layer disappears .',/,1x,
1'Enter the depths in meters !! ',/,1x,
1'To correct an entry enter CORR to return to previous layer.',/,1x,
1' To terminate input enter STOP .',//)
C-------LESE PARAMETER_FILE:
OPEN (UNIT=36,FILE='PARAMETER',
1 STATUS='OLD')
READ (36,'(A1)') C_DUM
READ (36,'(A1)') C_DUM
READ (36,'(A1)') C_DUM
READ (36,'(A1)') C_DUM
READ (36,'(A1)') C_DUM
READ (36,'(A30)') DATADIR
CLOSE (36,STATUS='KEEP')
C <DATA INPUT>
10 CONTINUE
TYPE *,' '
IF (L_FR) TYPE *,'---LAYERNAME--- FIRSTDEPTH LASTDEPTH'
L_FR = .FALSE.
READ (*,'(A80)',ERR=99) STRING
CALL EXT_VALUES
1 (RET_STAT,STRING,LAY_NA,LAY_BE,LAY_EN)
C <CHECK DEPTHS>
IF ((RET_STAT .EQ. 0) .AND.
1 (LAY_BE .GE. R_DIB) .AND.
1 (LAY_BE .LE. R_DIE) .AND.
1 (LAY_EN .GE. R_DIB) .AND.
1 (LAY_EN .LE. R_DIE) .AND.
1 (LAY_EN .GT. LAY_BE)) THEN
WRITE (UNIT_NO2) LAY_NA,LAY_BE,LAY_EN
ELSE
IF (STRING(1:4) .EQ. 'CORR') GOTO 99
IF (STRING(1:4) .EQ. 'STOP') GOTO 999
TYPE *,
1 '****** CANNOT DECODE OR WRONG DEPTH ,',
1 ' CHECK INPUT ! ENTER AGAIN : ******'
RET_STAT = 0
GOTO 10
END IF
GOTO 10
99 CONTINUE
RET_STAT = 0
BACKSPACE (UNIT_NO2)
READ (UNIT_NO2) LAY_NA,LAY_BE,LAY_EN
BACKSPACE (UNIT_NO2)
WRITE(*,*) 'NOW CORRECT : ',LAY_NA,' ',LAY_BE,' ',LAY_EN
GOTO 10
999 CONTINUE
ENDFILE (UNIT_NO2)
RET_STAT = 0
RETURN
END
CZ
SUBROUTINE LAYER_IN
1 (RET_STAT,UNIT_NO2,DIB,DIE,LAY_FIL_NAM)
C THIS SUBROUTINE IS USED FOR INPUT OF LAYER NAMES AND CABLE LENGTHS.
C JP MAR 88
IMPLICIT NONE !
INTEGER RET_STAT,
1 UNIT_NO2,
1 DIB, !LOGGING INTERVAL BEGIN OF DIRECTIONAL SURVEY
1 DIE !LOGGING INTERVAL END OF DIRECTIONAL SURVEY
CHARACTER*8 BUFFER
CHARACTER*15 LAY_NA !NAME OF LAYER
CHARACTER*30 LAY_FIL_NAM !FILENAME OF LAYER-DATA
REAL LAY_BE, !CABLE LENGTH TO LAYERBEGIN
1 LAY_EN !CABLE LENGTH TO LAYEREND
EQUIVALENCE (BUFFER,LAY_BE,LAY_EN)
C BEGIN:
WRITE (*,10) 'PROGRAM LAYER_IN JP MAR88'
10 FORMAT (//,1X,A50,//,1X,
1'THIS PROGRAM ASKS FOR - LAYER NAMES',/,1X,
1' - MEASURED CABLE LENGTH THE ',
1'LAYER APPEARS',/,1X,
1' - MEASURED CABLE LENGTH THE ',
1'LAYER DISAPPEARS .',/,1X,
1'TO CORRECT AN ENTRY ENTER CORR TO RETURN TO PREVIOUS LAYER.',/,1X,
1'TO TERMINATE INPUT PRESS RETURN UNTIL PROGRAM REACTS..'
OPEN (UNIT=UNIT_NO2,FILE=LAY_FIL_NAM//'.DAT',
1 STATUS='NEW',DEFAULTFILE=DATADIR,ACCESS=SEQUENTIAL,
1 FORM=UNFORMATTED)
REC_COUNTER = 0
C <DATA INPUT>
12 CONTINUE
REC_COUNTER = REC_COUNTER + 1
WRITE (*,112) 'LAYER NAME ? '
112 FORMAT (//,1X,A40,$)
READ (*,'(A15)',ERR=1112) LAY_NAM
IF (CHECK_CORR(LAY_NAM)) GOTO 500
IF (CHECK_END(LAY_NAM)) GOTO 600
GOTO 14
1112 WRITE (*,99)
GOTO 12
14 CONTINUE
WRITE (*,112) 'MEASURED LAYER BEGIN ? '
READ (*,'(A8)',ERR=1114) BUFFER1
IF (CHECK_CORR(BUFFER1)) GOTO 500
IF (CHECK_END(BUFFER1)) GOTO 600
IF (CHECK_NOTREAL(BUFFER1)) GOTO 1114
GOTO 16
1114 WRITE (*,99)
GOTO 14
16 CONTINUE
WRITE (*,112) 'MEASURED LAYER END ? '
READ (*,'(A8)',ERR=1116) BUFFER2
L_CORR = CHECK_CORR(BUFFER2)
IF (L_CORR) GOTO 500
L_END = CHECK_END(BUFFER2)
IF (L_END) GOTO 600
L_NOTREAL = CHECK_NOTREAL(BUFFER2)
IF (L_NOTREAL) GOTO 1116
GOTO 18
1116 WRITE (*,99)
GOTO 16
18 CONTINUE
IF (L_END) THEN
C <CONTROL FILE ?>
20 CONTINUE
WRITE (*,112) 'CONTROL INPUT (DEF=N/Y) ? '
READ (*,'(A1)') ICHAR
CALL LOGICAL_C_IN_NDEF (RET_STAT,ICHAR,L_CONTROL)
IF (L_CONTROL) THEN
CALL CONTROL_REC (UNIT_NO,DIB,DIE)
GOTO 20
END IF
C <CLOSE FILE>
CLOSE (UNIT_NO2)
END IF
RETURN
END
SUBROUTINE LOGICAL_C_IN_YDEF (RET_STAT,FLAG,INPUT_CHAR)
C INPUT_CHAR = 'N' --------> FLAG = .FALSE.
C INPUT_CHAR = 'Y' --------> FLAG = .TRUE.
C ELSE FLAG = .TRUE.
C J.P.22.4.1987
C J.P.23.3.1988
IMPLICIT NONE
INTEGER RET_STAT
CHARACTER*1 INPUT_CHAR
LOGICAL FLAG
RET_STAT = 0
IF (INPUT_CHAR .EQ. 'Y' .OR.
1 INPUT_CHAR .EQ. 'y' ) THEN
FLAG = .TRUE.
ELSE
IF (INPUT_CHAR .EQ. 'N' .OR.
1 INPUT_CHAR .EQ. 'n' ) THEN
FLAG = .FALSE.
ELSE
FLAG = .TRUE. !!
RET_STAT = 0
END IF
END IF
C WRITE(*,*)'SUB. LOGICAL_C_IN RET_STAT : ',RET_STAT
C WRITE(*,*)'FLAG : ',FLAG,' INPUT_CHAR : ',INPUT_CHAR
INPUT_CHAR = ' '
RETURN
END
SUBROUTINE MK
1 (MEKO,R,H,KEZI)
C DIESES PROGRAMM BERECHNET DIE MERIDIANKONVERGENZ ZUR ABBILDING VON VERLAUFS-
C MESSUNGEN IM GAUSS-KRUEGER SYSTEM. DIE FORMEL IST DEM BUCH VON WOLGANG SENGES
C ENTNOMMMEN : DER HP41, EIN KLEINRECHNER FUER DAS VERMESSUNGSWESEN,; S.159ff.
C ES GIBT EIN TESTPROGRAMM HIERZU : T_MK
C DER WINKEL DER MERIDIANKONVWRGENZ IST EBENFALLS IM RECHTSSYSTEM !!
C JP MAR88
C ABLAUFPLAN: 1.RECHNE STREIFENKENNZIFFERZUSCHLAG VON R AB
C 2.RECHNE MERIDIANKONVERGENZ
C 3.RUECKSPRUNG ZU AUFRUFENDEM PROGRAM
IMPLICIT NONE !!
C EINGABE PARAMETER:
REAL MEKO, !MERIDIANKONVERGENZ
1 L0 !GEOGRAPHISCHE LAENGE DES ORTSMERIDIANS DES GAUSS-KRUEGER-SYSTEMS
DOUBLE PRECISION
1 R, !RECHTSWERT
1 H !HOCHWERT
INTEGER KEZI !KENNZIFFER
C LOKALE VARIABLEN
DOUBLE PRECISION
1 LP, !GEOGRAPHISCHE LAENGE DES MESSPUNKTES
1 BP, !GEOGRAPHISCHE BREITE DES MESSPUNKTES
1 T, !TANGENS VON BP IN RADIAN
1 K, !COSINUS VON BP IN RADIAN
1 RHO0, !FAKTOR RADIAN ZU GRAD
1 V2,
1 N, !QUERKRUEMMUNGSHALBMESSER
1 NK,
1 ES2,
1 CE0, ! IN METER/ALTGRAD
1 G,
1 A, !GROSSE HALBACHSE BESSEL-ELLIPSOID
1 B, !KLEINE HALBACHSE
1 BR, !UM KENNZIFFERNZUSCHLAG BEREINIGTER RECHTSWERT
1 DL, !GEOGR. LAENGENDIFFERENZ IN ALTGRAD
1 LK !GEOGR. LAENGENDIFFERENZ IN RADIAN
PARAMETER (A = 6377397.155,
1 B = 6356078.963,
1 RHO0 = 180./3.1415926535898,
1 ES2 = (A*A-B*B)/(B*B),
1 NK = (A-B)/(A+B),
1 CE0 = 111120.6196)
C BEGIN:
C IF ( S .EQ. 0.) S = ELBOLE (A,B) !NEHME DOCH H
C
C G = S / CE0
G = H / CE0
C <BESTIMME BREITE DES MESSPUNKTES>
BP = G + ((3./2.*NK + (-27)/32*NK**2) * DSIN (2.*G) +
1 21/16*NK**2 * DSIN (4.*G) +
1 151/96*NK**3 * DSIN (6.*G)) * RHO0
D TYPE *,'BREITE MP : ',BP
C <RECHNE KENNZIFFERZUSCHLAG AB>
BR = R - DBLE(KEZI*1000000)-DBLE(500000)
D TYPE *,'BEREINIGTER RECHTSWERT : ',BR
C <BEREITE WERTE FUER FORMEL VOR>
T = DTAN (BP / RHO0)
K = DCOS (BP / RHO0)
V2 = 1. + ES2 * K**2
N = A**2 / (B*DSQRT(V2))
CD DL = (1./K*BR/N -
CD 1 (V2+2*T**2)/(6*K)*BR**3/N**3 +
CD 1 (1./(120.*K))*(5+28*T**2+ 24*T**4)*BR**5/N**5) * RHO0
CD TYPE *,'LEANGENDIFFERENZ : ',DL
CD LK = DL / RHO0
C <JETZT ABER : >
MEKO = SNGL ((T*BR/N - 1./3.*T*(2.+T**2-V2)*BR**3/N**3) * RHO0)
RETURN
END
SUBROUTINE PR_CL_NEWPAGE
1 (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
C-------EXPLANATION:
C THIS PROGRAM IS A PART OF THE PROGRAM DTV_CL, IT LISTS THE LOCATION OF
C LAYERS. THE OUTPUT-FILE IS ALREADY OPENED BY MAIN-PROGRAM
C JP APR 88
C-------DECLARATION:
IMPLICIT NONE !
INTEGER
1 OUTPUT, !UNIT_NO2
1 RET_STAT,
1 ROW_COUNTER,
1 SIDE_NUMBER
CHARACTER*40 LOCATION,
1 DATE
CHARACTER*1 FIRST_RUN
LOGICAL L_REF !.TRUE. IF GAUSS-KRUEGER OUTPUT
BYTE FF
SAVE FIRST_RUN
SAVE SIDE_NUMBER
DATA FF /12/
C.......BEGIN:
IF (FIRST_RUN .NE. 'N') THEN
SIDE_NUMBER = 1
FIRST_RUN = 'N'
END IF
SIDE_NUMBER = SIDE_NUMBER + 1
WRITE (OUTPUT,55,IOSTAT=RET_STAT) FF
WRITE (OUTPUT,555,IOSTAT=RET_STAT) SIDE_NUMBER,LOCATION,DATE
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'PRINT_NEW_PAGE')
ROW_COUNTER = 2
CALL PR_CL_SCHEDHEAD (RET_STAT,OUTPUT,ROW_COUNTER,L_REF)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'PRINT_SCHEDULE_HEAD')
C END;
RETURN
55 FORMAT (A1)
555 FORMAT (/,1X,'Seite ',I2,T12,A40,1X,A40)
END
CZ
SUBROUTINE PR_CL_SCHEDHEAD
1 (RET_STAT,OUTPUT,ROW_COUNTER,L_REF)
C-------EXPLANATION:
C THIS PROGRAM IS A PART OF THE PROGRAM DTV_CL, IT LISTS THE LOCATION OF
C WELL . THE OUTPUT-FILE IS ALREADY OPENED BY MAIN-PROGRAM.
C JP APR 88
C-------DECLARATION:
IMPLICIT NONE !
INTEGER
1 RET_STAT,
1 ROW_COUNTER,
1 OUTPUT !UNIT_NO2
LOGICAL L_REF !.TRUE. IF GAUSS-KRUEGER-OUTPUT
C.......BEGIN:
WRITE (OUTPUT,17,IOSTAT=RET_STAT)
IF (L_REF) THEN
WRITE (OUTPUT,19,IOSTAT=RET_STAT)
WRITE (OUTPUT,21,IOSTAT=RET_STAT)
WRITE (OUTPUT,23,IOSTAT=RET_STAT)
ELSE
WRITE (OUTPUT,119,IOSTAT=RET_STAT)
WRITE (OUTPUT,121,IOSTAT=RET_STAT)
WRITE (OUTPUT,123,IOSTAT=RET_STAT)
END IF
WRITE (OUTPUT,25,IOSTAT=RET_STAT)
ROW_COUNTER = ROW_COUNTER + 6
RETURN
17 FORMAT (1X,75('='),/)
19 FORMAT (1X,T1,' SCHICHT',
1 T27,'BOHR-',
1 T50,'KOORDINATEN')
21 FORMAT (1X,
1 T27,'LAENGE',
1 T41,'R',
1 T55,'H',
1 T69,'Z')
23 FORMAT (1X,T1,' ',
1 T27,' m',
1 T41,'m',
1 T55,'m',
1 T69,'m')
25 FORMAT (1X,75('-'))
119 FORMAT (1X,T1,' SCHICHT',
1 T27,'BOHR-',
1 T40,'WAHRE',
1 T58,'KOORDINATEN')
121 FORMAT (1X,
1 T27,'LAENGE',
1 T40,'TEUFE',
1 T55,'+N/-S',
1 T67,'+E/-W')
123 FORMAT (1X,T1,' ',
1 T27,' m',
1 T42,'m',
1 T57,'m',
1 T69,'m')
END
CZ
SUBROUTINE SEARCH_DEPTH
1 (UNIT_NO,DIBNB,DIBNE,R_DIB,R_DIE)
C THIS PROGRAM SEARCHS FOR LOGGING DEPTH INTERVAL.
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !!
C INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
INCLUDE 'DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(COM_FBLK)'
INTEGER
1 DIBNB, !DEPTH INTERVAL BLOCK NUMBER BEGIN
1 DIBNE, !DEPTH INTERVAL BLOCK NUMBER END
C 1 DIB, !DEPTH INTERVAL BEGIN !IN mm!
C 1 DIE, !DEPTH INTERVAL END !IN mm!
1 ROW,
1 UNIT_NO,
5 RET_STAT,
* B_NEXT, !PREVIOUS FILEBLOCK OF SAME DATA KIND
* F_NEXT, !NEXT FILEBLOCK OF SAME DATA KIND
1 FBLK_NO
LOGICAL L_FR
REAL R_DIB,
1 R_DIE
C.......BEGIN
D TYPE *,'SEARCH DEPTH..'
L_FR = .TRUE.
FBLK_NO = DIBNB
DO WHILE (FBLK_NO .LE. DIBNE .AND. FBLK_NO .NE. 0)
CALL DATV_RDWC (RET_STAT,UNIT_NO,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
ROW = 0
DO WHILE (ROW .LT. DR$Y_SIZE)
IF (L_FR) THEN
R_DIB = FB_DATA(P_M_DEPTH)
R_DIE = R_DIB
L_FR = .FALSE.
ELSE
IF (FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE) .GT. R_DIE)
1 R_DIE = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
END IF
D TYPE *,'R_DIB : ',R_DIB,' R_DIE : ',R_DIE
ROW = ROW + 1
END DO !WHILE
FBLK_NO = F_NEXT
END DO !WHILE
RETURN
END
CZ