SUBROUTINE ANGL_AVER
C-------SCHNELLVERSION JP 6.4.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C COORDINATES ARE COMPUTED IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH START-POINT (0.,0.,0) !
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 ROW
REAL
1 M_DEPTH_OLD,
1 DIP_OLD,
1 AZI_OLD,
1 DIPM,
1 AZIM,
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DELTA_DEPTH
DOUBLE PRECISION
1 REF_Z, !START-COORDINATES
1 REF_Y,
1 REF_X,
1 Z, !MP-COORDINATES
1 Y,
1 X
CHARACTER*1 FIRST_RUN
C BEGIN:
ROW = 0
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
DO WHILE (ROW .LT. DR$X_SIZE .AND.
1 TYPE_OF_TOOL .NE. 0)
D TYPE *,'COMPUTE ROW NO.',ROW+1,' MAX: ',DR$X_SIZE
IF (FIRST_RUN .NE. 'N') THEN
D TYPE *,'FIRST_RUN TANGE_MET'
C >GET REFERENCE COORDINATES FROM START-POINT<
MSZ = FB_DATA(P_MSZ)
MSZ = FB_DATA(P_LSZ)
CALL EXT_2RIDP (REF_Z,MSZ,MSZ)
MSY = FB_DATA(P_MSY)
MSY = FB_DATA(P_LSY)
CALL EXT_2RIDP (REF_Y,MSY,MSY)
MSX = FB_DATA(P_MSX)
MSX = FB_DATA(P_LSX)
CALL EXT_2RIDP (REF_X,MSX,MSX)
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
DEPTH = COURSE_LEN * COS(DIP) + DEPTH
M_DEPTH_OLD = M_DEPTH
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FIRST_RUN = 'N'
ELSE
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
C IF (M_DEPTH .NE. 0.) THEN !NOT FIRST RUN
COURSE_LEN = M_DEPTH - M_DEPTH_OLD
M_DEPTH_OLD = M_DEPTH
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
END IF
DIPM = (DIP+DIP_OLD)/2.
AZIM = (AZI+AZI_OLD)/2.
DELTA_DEPTH = COURSE_LEN * COS(DIPM)
DEPTH = DEPTH + DELTA_DEPTH
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN *
1 SIN(DIPM) * COS(AZIM) ) + Y
X = DBLE(COURSE_LEN *
1 SIN(DIPM) * SIN(AZIM) ) + X
C >CONVERT DOUBLE PRECISION INTO TWO REAL VALUES<
CALL EXT_DPI2R (Z,MSZ,LSZ)
CALL EXT_DPI2R (Y,MSY,LSY)
CALL EXT_DPI2R (X,MSX,LSX)
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FB_DATA (P_DEPTH+ROW*DR$Y_SIZE) = DEPTH
FB_DATA (P_DIP+ROW*DR$Y_SIZE) = DIP
FB_DATA (P_AZI+ROW*DR$Y_SIZE) = AZI
FB_DATA (P_MSZ+ROW*DR$Y_SIZE) = MSZ
FB_DATA (P_LSZ+ROW*DR$Y_SIZE) = LSZ
FB_DATA (P_MSY+ROW*DR$Y_SIZE) = MSY
FB_DATA (P_LSY+ROW*DR$Y_SIZE) = LSY
FB_DATA (P_MSX+ROW*DR$Y_SIZE) = MSX
FB_DATA (P_LSX+ROW*DR$Y_SIZE) = LSX
D TYPE *,'DEPTH :',DEPTH
D TYPE *,'DIP :',DIP
D TYPE *,'AZI :',AZI
D TYPE *,'MSZ :',MSZ
D TYPE *,'LSZ :',LSZ
D TYPE *,'MSY :',MSY
D TYPE *,'LSY :',LSY
D TYPE *,'MSX :',MSX
D TYPE *,'LSX :',LSX
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+ROW*DR$Y_SIZE)
END DO !WHILE
C END;
RETURN
END
SUBROUTINE BALAC_TA_MET
C-------SCHNELLVERSION JP 6.4.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C COORDINATES ARE COMPUTED IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH START-POINT (0.,0.,0) !
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 ROW
REAL
1 M_DEPTH_OLD,
1 DIP_OLD,
1 AZI_OLD,
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DELTA_DEPTH
DOUBLE PRECISION
1 REF_Z, !START-COORDINATES
1 REF_Y,
1 REF_X,
1 Z, !MP-COORDINATES
1 Y,
1 X
CHARACTER*1 FIRST_RUN
C BEGIN:
ROW = 0
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
DO WHILE (ROW .LT. DR$X_SIZE .AND.
1 TYPE_OF_TOOL .NE. 0)
D TYPE *,'COMPUTE ROW NO.',ROW+1,' MAX: ',DR$X_SIZE
IF (FIRST_RUN .NE. 'N') THEN
D TYPE *,'FIRST_RUN TANGE_MET'
C >GET REFERENCE COORDINATES FROM START-POINT<
MSZ = FB_DATA(P_MSZ)
MSZ = FB_DATA(P_LSZ)
CALL EXT_2RIDP (REF_Z,MSZ,MSZ)
MSY = FB_DATA(P_MSY)
MSY = FB_DATA(P_LSY)
CALL EXT_2RIDP (REF_Y,MSY,MSY)
MSX = FB_DATA(P_MSX)
MSX = FB_DATA(P_LSX)
CALL EXT_2RIDP (REF_X,MSX,MSX)
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
DEPTH = COURSE_LEN * COS(DIP) + DEPTH
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FIRST_RUN = 'N'
ELSE
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
C IF (M_DEPTH .NE. 0.) THEN !NOT FIRST RUN
COURSE_LEN = M_DEPTH - M_DEPTH_OLD
M_DEPTH_OLD = M_DEPTH
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
END IF
DELTA_DEPTH = COURSE_LEN/2. * (COS(DIP)+COS(DIP_OLD))
DEPTH = DEPTH + DELTA_DEPTH
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*COS(AZI)+SIN(DIP_OLD)*COS(AZI_OLD))) + Y
X = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*SIN(AZI)+SIN(DIP_OLD)*SIN(AZI_OLD))) + X
C >CONVERT DOUBLE PRECISION INTO TWO REAL VALUES<
CALL EXT_DPI2R (Z,MSZ,LSZ)
CALL EXT_DPI2R (Y,MSY,LSY)
CALL EXT_DPI2R (X,MSX,LSX)
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FB_DATA (P_DEPTH+ROW*DR$Y_SIZE) = DEPTH
FB_DATA (P_DIP+ROW*DR$Y_SIZE) = DIP
FB_DATA (P_AZI+ROW*DR$Y_SIZE) = AZI
FB_DATA (P_MSZ+ROW*DR$Y_SIZE) = MSZ
FB_DATA (P_LSZ+ROW*DR$Y_SIZE) = LSZ
FB_DATA (P_MSY+ROW*DR$Y_SIZE) = MSY
FB_DATA (P_LSY+ROW*DR$Y_SIZE) = LSY
FB_DATA (P_MSX+ROW*DR$Y_SIZE) = MSX
FB_DATA (P_LSX+ROW*DR$Y_SIZE) = LSX
D TYPE *,'DEPTH :',DEPTH
D TYPE *,'DIP :',DIP
D TYPE *,'AZI :',AZI
D TYPE *,'MSZ :',MSZ
D TYPE *,'LSZ :',LSZ
D TYPE *,'MSY :',MSY
D TYPE *,'LSY :',LSY
D TYPE *,'MSX :',MSX
D TYPE *,'LSX :',LSX
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+ROW*DR$Y_SIZE)
END DO !WHILE
C END;
RETURN
END
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 CO_CO
1 (L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,L_MINICU,L_MODEL4)
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE COORDINATES OF DEVIATION.
C THE CALIBRATED DATA IS STORED IN A DTV-FILE WITH DATA_KIND 12.
C NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA** . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C YOU CAN CHOOSE ONE OF 6 MODELS TO COMPUTE THE COORDINATES OF DEVIATION:
C Tangential Method
C Balanced Tangential Method
C Angle-Averaging Method
C Radius of Curvature
C Minimum Curvature
C Walstrom''s model 4
C COORDINATES IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH START-POINT (0.,0.,0) !
C JP SINCE JUNE 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 ROW, !1..DR$Y_SIZE!
1 I
REAL
1 DEPTH_OLD,
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DIP_OLD,
1 AHD_OLD,
1 DIPM,
1 AHDM,
1 DIPDIFF,
1 AHDDIFF,
1 DELTA_DEPTH,
1 NENNER,
1 K, !CORRECTION-VALUE USED FOR MINI_CURV
1 TANK, !TAN(K/2.)/K " " "
1 ZAEHLER1,ZAEHLER2,ZAEHLER3,ZAEHLER4,
1 NENNER1,NENNER2,NENNER3
DOUBLE PRECISION
1 Z, !MP-COORDINATES
1 Y,
1 X
CHARACTER*1 FIRST_RUN
LOGICAL L_BALA_MET, !.TRUE. IF DIP AND AHD DON'T CHANGE
1 L_TANMET,
1 L_BATAME,
1 L_ANGAVE,
1 L_RADIOC,
1 L_MINICU,
1 L_MODEL4
C BEGIN:
D IF (L_TANMET) WRITE(*,*) 'TANGENTIAL METHOD :'
D IF (L_BATAME) WRITE(*,*) 'BALANCED TANGENTIAL METHOD :'
D IF (L_ANGAVE) WRITE(*,*) 'ANGLE AVERAGING METHOD :'
D IF (L_RADIOC) WRITE(*,*) 'RADIUS OF CURVATURE METHOD :'
D IF (L_MINICU) WRITE(*,*) 'MINIMUM CURVATURE METHOD :'
D IF (L_MODEL4) WRITE(*,*) '''WALSTROM''S MODEL 4'' METHOD :'
ROW = 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
DO WHILE (ROW .LE. DR$X_SIZE .AND.
1 TYPE_OF_TOOL .NE. 0)
IF (FIRST_RUN .NE. 'N') THEN
C >GET REFERENCE COORDINATES FROM START-POINT<
MSZ = FB_DATA(P_MSZ)
MSZ = FB_DATA(P_LSZ)
CALL EXT_2RIDP (Z,MSZ,MSZ)
MSY = FB_DATA(P_MSY)
MSY = FB_DATA(P_LSY)
CALL EXT_2RIDP (Y,MSY,MSY)
MSX = FB_DATA(P_MSX)
MSX = FB_DATA(P_LSX)
CALL EXT_2RIDP (X,MSX,MSX)
DEPTH = FB_DATA(P_DEPTH+(ROW-1)*DR$Y_SIZE)
DEPTH_OLD = DEPTH
DEPTH = COURSE_LEN * COS(DIP) + DEPTH
DIP = FB_DATA(P_DIP+(ROW-1)*DR$Y_SIZE)
AHD = FB_DATA(P_AHD+(ROW-1)*DR$Y_SIZE)
DIP_OLD = DIP
AHD_OLD = AHD
COURSE_LEN = 0.
C >PRESET COORDINATE ERRORS AND STORE THEM<
CALL CO_CO_ERR (ROW,COURSE_LEN,DELTA_DEPTH,
1 Z,Y,X)
FIRST_RUN = 'N'
ELSE
DEPTH = FB_DATA(P_DEPTH+(ROW-1)*DR$Y_SIZE)
D TYPE *,'DEPTH :',DEPTH
COURSE_LEN = DEPTH - DEPTH_OLD
DEPTH_OLD = DEPTH
DIP = FB_DATA(P_DIP+(ROW-1)*DR$Y_SIZE)
AHD = FB_DATA(P_AHD+(ROW-1)*DR$Y_SIZE)
IF (L_TANMET) THEN
DELTA_DEPTH = COURSE_LEN * COS(DIP)
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN*SIN(DIP)*COS(AHD)) + Y
X = DBLE(COURSE_LEN*SIN(DIP)*SIN(AHD)) + X
ELSE IF (L_BATAME) THEN
DELTA_DEPTH = COURSE_LEN/2. * (COS(DIP)+COS(DIP_OLD))
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*COS(AHD)+SIN(DIP_OLD)*COS(AHD_OLD))) + Y
X = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*SIN(AHD)+SIN(DIP_OLD)*SIN(AHD_OLD))) + X
ELSE IF (L_ANGAVE) THEN
DIPM = (DIP+DIP_OLD)/2.
AHDM = (AHD+AHD_OLD)/2.
DELTA_DEPTH = COURSE_LEN * COS(DIPM)
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN *
1 SIN(DIPM) * COS(AHDM) ) + Y
X = DBLE(COURSE_LEN *
1 SIN(DIPM) * SIN(AHDM) ) + X
ELSE IF (L_RADIOC) THEN
DIPDIFF = DIP - DIP_OLD
AHDDIFF = AHD - AHD_OLD
NENNER = DIPDIFF * AHDDIFF
IF (DIPDIFF .NE. 0.) THEN
DELTA_DEPTH = COURSE_LEN * (SIN(DIP)-SIN(DIP_OLD)) /
1 DIPDIFF
ELSE
DELTA_DEPTH = COURSE_LEN * COS (DIP)
END IF
Z = DBLE(DELTA_DEPTH) + Z
IF (NENNER .NE. 0.) THEN
Y = DBLE(COURSE_LEN * (COS(DIP_OLD)-COS(DIP)) *
1 (SIN(AHD)-SIN(AHD_OLD)) / NENNER ) + Y
X = DBLE(COURSE_LEN * (COS(DIP_OLD)-COS(DIP)) *
1 (COS(AHD_OLD)-COS(AHD)) / NENNER ) + X
ELSE
Y = DBLE(COURSE_LEN * SIN((DIP_OLD+DIP)/2.) *
1 COS((AHD+AHD_OLD)/2.) ) + Y
X = DBLE(COURSE_LEN * SIN((DIP_OLD+DIP)/2.) *
1 SIN((AHD+AHD_OLD)/2.) ) + X
END IF
ELSE IF (L_MINICU) THEN
K = ACOS (COS(DIP-DIP_OLD)-
1 2*SIN(DIP_OLD)*SIN(DIP)*
1 (SIN((AHD_OLD-AHD)/2.)**2.))
IF (ABS(K) .LT. .1E-05) L_BALA_MET = .TRUE.
D IF (L_BALA_MET) TYPE *,'USE BALANCED TANGENTIAL METHOD'
D IF (.NOT.L_BALA_MET) TYPE *,'USE MINIMUM CURVATURE METHOD'
IF (.NOT. L_BALA_MET) THEN
TANK = TAN(K/2.)/K
DELTA_DEPTH = COURSE_LEN * TANK*(COS(DIP)+COS(DIP_OLD))
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN * TANK *
1 (SIN(DIP)*COS(AHD)+SIN(DIP_OLD)*COS(AHD_OLD))) + Y
X = DBLE(COURSE_LEN * TANK *
1 (SIN(DIP_OLD)*SIN(AHD_OLD)+SIN(DIP)*SIN(AHD))) + X
ELSE
DELTA_DEPTH = COURSE_LEN/2. * (COS(DIP)+COS(DIP_OLD))
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*COS(AHD)+SIN(DIP_OLD)*COS(AHD_OLD))) + Y
X = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*SIN(AHD)+SIN(DIP_OLD)*SIN(AHD_OLD))) + X
L_BALA_MET = .FALSE.
END IF
ELSE IF (L_MODEL4) THEN
ZAEHLER1 = DIP-AHD+DIP_OLD-AHD_OLD
ZAEHLER2 = DIP-AHD-DIP_OLD+AHD_OLD
ZAEHLER3 = DIP+AHD+DIP_OLD+AHD_OLD
ZAEHLER4 = DIP+AHD-DIP_OLD-AHD_OLD
NENNER1 = ZAEHLER2
NENNER2 = ZAEHLER4
NENNER3 = DIP-DIP_OLD
IF (ABS(NENNER3) .LT. ERR_DIP .OR.
1 ABS(NENNER3) .LT. .1E-20) THEN
DELTA_DEPTH = COURSE_LEN * COS ((DIP+DIP_OLD)/2.)
ELSE
DELTA_DEPTH = COURSE_LEN *
1 ((SIN(DIP)-SIN(DIP_OLD))/NENNER3)
END IF
Z = DBLE(DELTA_DEPTH) + Z
IF (ABS(NENNER1) .LT. .1E-10 .OR.
1 ABS(NENNER2) .LT. .1E-10) THEN
D TYPE *,'NENNER1 OR 2 TOO SMALL -< BALANCED TANGENTIAL METHOD'
Y = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*COS(AHD)+SIN(DIP_OLD)*COS(AHD_OLD))) + Y
X = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*SIN(AHD)+SIN(DIP_OLD)*SIN(AHD_OLD))) + X
ELSE
D TYPE *,'NORMAL EXEC'
Y = DBLE(COURSE_LEN *
1 ((SIN(ZAEHLER3/2.)*SIN(ZAEHLER4/2.))/NENNER2 +
2 (SIN(ZAEHLER1/2.)*SIN(ZAEHLER2/2.))/NENNER1)) + Y
X = DBLE(COURSE_LEN *
1 ((COS(ZAEHLER1/2.)*SIN(ZAEHLER2/2.))/NENNER1 -
2 (COS(ZAEHLER3/2.)*SIN(ZAEHLER4/2.))/NENNER2)) + X
END IF
ELSE
WRITE (*,*)
1 ('*******CHOOSE A METHOD TO COMPUTE DEVIATION OF WELL*******',
1 I=1,10)
STOP
END IF
DIP_OLD = DIP
AHD_OLD = AHD
C >COMPUTE COORDINATE ERRORS AND STORE THEM<
CALL CO_CO_ERR (ROW,COURSE_LEN,DELTA_DEPTH,
1 Z,Y,X)
C >CONVERT DOUBLE PRECISION INTO TWO REAL VALUES<
CALL EXT_DPI2R (Z,MSZ,LSZ)
CALL EXT_DPI2R (Y,MSY,LSY)
CALL EXT_DPI2R (X,MSX,LSX)
END IF
FB_DATA (P_MSZ+(ROW-1)*DR$Y_SIZE) = MSZ
FB_DATA (P_LSZ+(ROW-1)*DR$Y_SIZE) = LSZ
FB_DATA (P_MSY+(ROW-1)*DR$Y_SIZE) = MSY
FB_DATA (P_LSY+(ROW-1)*DR$Y_SIZE) = LSY
FB_DATA (P_MSX+(ROW-1)*DR$Y_SIZE) = MSX
FB_DATA (P_LSX+(ROW-1)*DR$Y_SIZE) = LSX
D TYPE *,'Z :',Z,'+-',FB_DATA(P_ERR_Z+(ROW-1)*DR$Y_SIZE)
D TYPE *,'Y :',Y,'+-',FB_DATA(P_ERR_Y+(ROW-1)*DR$Y_SIZE)
D TYPE *,'X :',X,'+-',FB_DATA(P_ERR_X+(ROW-1)*DR$Y_SIZE)
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+(ROW-1)*DR$Y_SIZE)
END DO !WHILE
C END;
RETURN
END
CB650
SUBROUTINE CO_CO_ERR (ROW,COURSE_LEN,DELTA_DEPTH,
1 Z,Y,X)
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE COORDINATE ERRORS. THE PROGRAM IS CALLED BY THE
C SEVERAL SUBROUTINES TO COMPUTE THE COORDINATES OF WELL.
C COORDINATES ARE COMPUTED IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH
C START-POINT (0.,0.,0) !
C JP MAY 88
C-------DECLARATION:
IMPLICIT NONE !
INCLUDE 'DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(COM_FBLK)'
INTEGER
1 ROW !ACTUAL ROW IN FB_DATA
REAL
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DELTA_DEPTH, !COURSE_LEN * COS(DIP)
1 DX,DY,DZ, !DIFFERENCE OF COORDINATES BETWEEN LAST AND ACTUAL MP
1 ADX,ADY, !AZIMUT-ERROR IN X AND Y DIRECTION
1 LDX,LDY, !LENGTH-SHIFT IN X AND Y DIRECTION
1 HDX,HDY,HDZ, !HEIGTH-ANGLE-ERROR IN Z,Y AND X DIRECTION
1 AHD_OLD !TO COMPUTE DIRECTION-ANGLE BETWEEN LAST AND ACTUAL MP
DOUBLE PRECISION
1 Z, !MP-COORDINATES
1 Y,
1 X,
1 LZ,LY,LX !PREVIOUS MP-COORDINATES
CHARACTER*1 FIRST_RUN
C BEGIN:
C TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
IF (FIRST_RUN .NE. 'N') THEN
C >BESETZE DX,DY,DZ UND HOFFE, DASS DIE WERTE WENIGER ALS 8 STELLEN HABEN,
C DIE ERSTEN WERTE SEIEN FEHLERFREI<
AHD_OLD = FB_DATA((ROW-1)*DR$Y_SIZE+P_AHD) !MUSS AUF RAD NORMIERT SEIN!
DZ = REAL (Z)
DY = REAL (Y)
DX = REAL (X)
ADX = 0.
ADY = 0.
LDX = 0.
LDY = 0.
HDZ = 0.
ERR_Z = 0.
ERR_Y = 0.
ERR_X = 0.
FIRST_RUN = 'N'
ELSE
DZ = REAL (LZ-Z)
DY = REAL (LY-Y)
DX = REAL (LX-X)
ERR_AHD = FB_DATA((ROW-1)*DR$Y_SIZE+P_ERR_AHD) !MUSS AUF RAD NORMIERT SEIN!
ERR_DIP = FB_DATA((ROW-1)*DR$Y_SIZE+P_ERR_DIP) !MUSS AUF RAD NORMIERT SEIN!
ERR_DEPTH = FB_DATA((ROW-1)*DR$Y_SIZE+P_ERR_DEPTH)
AHD = FB_DATA((ROW-1)*DR$Y_SIZE+P_AHD) !MUSS AUF RAD NORMIERT SEIN!
DIP = FB_DATA((ROW-1)*DR$Y_SIZE+P_DIP) !MUSS AUF RAD NORMIERT SEIN!
ADX = ADX + (DX*ERR_AHD)**2.
ADY = ADY + (DX*ERR_AHD)**2.
C LDX = LDX + (DELTA_DEPTH*ERR_DIP*SIN(AHD-AHD_OLD))**2.
C LDY = LDY + (DELTA_DEPTH*ERR_DIP*COS(AHD-AHD_OLD))**2.
LDX = LDX + (DELTA_DEPTH*ERR_DIP*SIN(AHD))**2.
LDY = LDY + (DELTA_DEPTH*ERR_DIP*COS(AHD))**2.
HDX = HDX + (DELTA_DEPTH*ERR_DIP)**2.
HDY = HDX
HDZ = HDZ + (COURSE_LEN*SIN(DIP)*ERR_DIP)**2.
ERR_Z = SQRT (HDZ + ERR_DEPTH**2.)
ERR_Y = SQRT (ADY + LDY + HDY)
ERR_X = SQRT (ADX + LDX + HDY)
END IF
FB_DATA((ROW-1)*DR$Y_SIZE+P_ERR_Z) = ERR_Z
FB_DATA((ROW-1)*DR$Y_SIZE+P_ERR_Y) = ERR_Y
FB_DATA((ROW-1)*DR$Y_SIZE+P_ERR_X) = ERR_X
LZ = Z
LY = Y
LX = X
AHD_OLD = AHD
C END;
RETURN
END
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 IN METERS
C 18 ACCUMULATED ERROR OF DEPTH IN METERS
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_DR
C-------JP SINCE 13.3.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY A PROGRAM ZEDA** . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C "FLOWCHART" :
C 1.READ TOOLTYPE
C 2.COMPUTE DIRECTIONAL SURVEY , POSSIBLE METHODS : - POLYGON
C - BALANCED TANG.
C - ANGLE AVERAGE
C - RADIUS OF
C CURVATURE
C - MINIMUM CURVATURE
C - WALSTROMS MODEL 4
C 3.METHOD OF DIRECTIONAL COMPUTATION
C IS WRITTEN TO FILE-HISTORY-SEGMENT (1ST BLOCK)
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !
INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(COM_FBLK)'
INCLUDE '(LOC_FSH)'
INTEGER
1 B_NEXT,
1 F_NEXT,
1 FBLK_NO,
1 ROW,
1 UNIT_NO1,
1 UNIT_NO2,
3 D_KIND(BHT$DF_MAXE), !DATA KINDS
5 FBLK_BEG(BHT$DF_MAXE),
6 FBLK_END(BHT$DF_MAXE),
7 DIB, !DEPTH INTERVAL BEGIN
8 DIE, !" " END
3 DAFO_XS(BHT$DF_MAXE), !DATA FORMAT X SIZE
4 DAFO_YS(BHT$DF_MAXE), ! Y
5 DAFO_ZS(BHT$DF_MAXE), ! Z
6 I_FN
LOGICAL DIRECTION, !.T IF LOGGING DIRECTION FROM
C ! BOTTOM TO TOP
1 L_TANMET, !
1 L_BATAME,
1 L_ANGAVE,
1 L_RADIOC,
1 L_MINICU,
1 L_MODEL4,
1 L_FR
REAL GHSCALE, !DEPTH SAMPLE INTERVAL
1 M_DEPTH_OLD,
1 GES_AB,
* SE_DFMIN, !MINIMUM LIMIT OF DATA
* SE_DFMAX !MAXIMUM LIMIT OF DATA
INTEGER I,J,K,
1 N, !NUMBER OF FFT SAMPLES :MAX.
5 RET_STAT,
4 IANSWER
CHARACTER*1 C_REF
CHARACTER*60 FILE_NAME
CHARACTER*9 EXECUTIVE
CHARACTER*3 TOOL
INTEGER
* DI_ECNT, !DEPTH INTERVAL SEG. ENTRY COUNT
* DF_ECNT, !DATA FORMAT SEGMENT ENRTY COUNT
* FH_ECNT,
* 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
* ENTRY_NO, !ENTRY NUMBER DATV_RDWC
* SE_FHBB,
* SE_FHBE
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
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'PROGRAM "DTV_DR". JP SINCE MAR.88'
WRITE(*,*)
C LESE PARAMETER_FILE:
OPEN (UNIT=36,FILE='PARAMETER',
1 STATUS='OLD')
READ (36,'(A30)') FILE_NAME
READ (36,'(A3)') TOOL
READ (36,'(A1)')
READ (36,'(A1)') !DIRECTORY
READ (36,'(A1)')
READ (36,'(A1)')
READ (36,'(A>FSH$FHEXE_L<)') EXECUTIVE
CLOSE (36,STATUS='KEEP')
DECODE (3,'(F3.1)',TOOL) TYPE_OF_TOOL
1 CONTINUE
CALL LIB$GET_LUN(UNIT_NO1)
CALL LIB$GET_LUN(UNIT_NO2)
IF (UNIT_NO1 .LT. 7 .OR. UNIT_NO2 .LT. 7) THEN
WRITE(*,*)'ERROR WITH UNIT NUMBER :',UNIT_NO1, UNIT_NO2
PAUSE 'TYPE CONTINUE OR EXIT'
GOTO 1
END IF
C >OEFFNE DATEN-FILE<
CALL DATV_OPEN (UNIT_NO1,FILE_NAME,'OLD',RET_STAT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_OPRO')
C.......LESE BEARBEITUNGS-SCHRITTE:
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 , 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')
WRITE(*,*) 'DATA ALREADY PROCESSED BY : ',SE_FHMOD
IF (.NOT.(SE_FHMOD(1:3).EQ.'ZED' .OR. SE_FHMOD(1:3).EQ.'DR_'))
1 WRITE(*,*)
1 (' **** WRONG PROCESSING **** PROCESS NOT ALLOWED ****',I=1,10)
END DO
C.......LESE DATA_KIND:
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
IF (SE_DFKI .NE. 12) CALL RETSTAT (RET_STAT,'WRONG DATA-KIND')
DAFO_XS(1) = SE_DFXS
DAFO_YS(1) = SE_DFYS
C.......LESE ANZAHL DER BLOECKE:
DO ENTRY_NO = 1 , DI_ECNT
CALL FSHDI_SEG ('READ',RET_STAT,ENTRY_NO,
* SE_DIB,SE_DIBNB,SE_DIE,SE_DIBNE)
1000 CONTINUE
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHDI_SEG')
END DO
FBLK_BEG(1) = SE_DIBNB !ASSUME THAT THERE'S ONLY ONE ENTRY!
FBLK_END(1) = SE_DIBNE
C.......RECHNE
112 CONTINUE
TYPE *,' '
TYPE *,'WAEHLE RECHENMETHODE FUER VERLAUFSRECHNUNG :'
TYPE *,'Tangential Method 1'
TYPE *,'Balanced Tangential Method 2'
TYPE *,'Angle-Averaging Method 3'
TYPE *,'Radius of Curvature 4'
TYPE *,'Minimum Curvature 5'
TYPE *,'Walstrom''s model 4 6'
C 1234567890123456789012345678901234567890
12 FORMAT (1X,A33,$)
WRITE(*,12) ' '
READ (*,*,ERR=112) IANSWER
IF (IANSWER .EQ. 1) THEN
L_TANMET = .TRUE.
FH_MOD = 'DR_TANMET'
ELSE IF (IANSWER .EQ. 2) THEN
L_BATAME = .TRUE.
FH_MOD = 'DR_BATAME'
ELSE IF (IANSWER .EQ. 3) THEN
L_ANGAVE = .TRUE.
FH_MOD = 'DR_ANGAVE'
ELSE IF (IANSWER .EQ. 4) THEN
L_RADIOC = .TRUE.
FH_MOD = 'DR_RADIOC'
ELSE IF (IANSWER .EQ. 5) THEN
L_MINICU = .TRUE.
FH_MOD = 'DR_MINICU'
ELSE IF (IANSWER .EQ. 6) THEN
L_MODEL4 = .TRUE.
FH_MOD = 'DR_MODEL4'
ELSE
GOTO 112
END IF
FBLK_NO = FBLK_BEG(1)
D TYPE *,'READ FBLK ',FBLK_NO
C DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0 .AND.
C 1 DIE .LT. M_DEPTH)
DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0)
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 >RECHNE KOORDINATEN NACH DEN VERSCHIEDENEN METHODEN AUS<
CALL CO_CO
1 (L_TANMET,L_BATAME,L_ANGAVE,L_RADIOC,L_MINICU,L_MODEL4)
C >SCHREIBE DIE DATEN WEG<
CALL DATV_WRTWC (UNIT_NO1,FBLK_NO)
FBLK_NO = F_NEXT
END DO !WHILE
C...SCHREIBE IN FILE HISTORY SEGMENT:
CALL LOG_MODULEX (UNIT_NO1,EXECUTIVE,FH_MOD,FBLK_BEG(1),FBLK_END(1))
CALL LIB$FREE_LUN(UNIT_NO1)
CALL LIB$FREE_LUN(UNIT_NO2)
991 FORMAT (/,10X,
1'****DIE EINGABE DER KOMPASS-MISSWEISUNG ERUEBRIGT SICH ',
1/,10X,
1' DA IN DER VERROHUNG GEMESSEN WURDE ****')
992 FORMAT (/,1X,
1 '*** DAMIT KANN ICH NICHTS ANFANGEN, ',
1 'BITTE NOCHMAL ANDERS EINGEBEN ***',/)
END
CZ
PROGRAM DTV_DR_B
C-------SCHNELLVERSION JP 13.3.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C "FLOWCHART" :
C 1.READ TOOLTYPE
C 2.READ CORRESPONDING FILE WITH CALIBRATION PARAMETERS
C 3.READ DATA(OFFSET 0-9) AND TRANSFORM (OFFSET 10-64)
C 3A.EVENTUALLY FILTERING OF DATA
C 4.COMPUTE DIRECTIONAL SURVEY , POSSIBLE METHODS : - POLYGON
C - BALANCED TANG.
C - RADIUS OF
C CURVATURE
C 5.FILTERING AND METHOD OF DIRECTIONAL COMPUTATION
C IS WRITTEN TO FILE-HISTORY-SEGMENT (1ST BLOCK)
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !
INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(COM_FBLK)'
INCLUDE '(LOC_FSH)'
INTEGER
1 B_NEXT,
1 F_NEXT,
1 FBLK_NO,
1 ROW,
1 UNIT_NO1,
1 UNIT_NO2,
3 D_KIND(BHT$DF_MAXE), !DATA KINDS
5 FBLK_BEG(BHT$DF_MAXE),
6 FBLK_END(BHT$DF_MAXE),
7 DIB, !DEPTH INTERVAL BEGIN
8 DIE, !" " END
3 DAFO_XS(BHT$DF_MAXE), !DATA FORMAT X SIZE
4 DAFO_YS(BHT$DF_MAXE), ! Y
5 DAFO_ZS(BHT$DF_MAXE), ! Z
6 I_FN
LOGICAL DIRECTION, !.T IF LOGGING DIRECTION FROM
C ! BOTTOM TO TOP
1 L_TANMET, !
1 L_BATAME,
1 L_ANGAVE,
1 L_RADIOC,
1 L_MINICU,
1 L_MODEL4,
1 L_REF, !.T IF GAUSS-KRUEGER OUTPUT
1 L_DEC, !.T IF DECLINATION OF MAGNETIC FIELD KNOWN
1 L_AZI, !.T IF MEASURED IN OPEN HOLE
1 L_FR
REAL GHSCALE, !DEPTH SAMPLE INTERVAL
1 M_DEPTH_OLD,
1 GES_AB,
* SE_DFMIN, !MINIMUM LIMIT OF DATA
* SE_DFMAX !MAXIMUM LIMIT OF DATA
INTEGER I,J,K,
1 N, !NUMBER OF FFT SAMPLES :MAX.
5 RET_STAT,
4 IANSWER
CHARACTER*1 ANSWER,
1 C_AZI,
1 C_REF,
1 C_DEC
CHARACTER*60 FILE_NAME
CHARACTER*60 CAL_FILE_NAME
CHARACTER*10 CMAGDECL
CHARACTER*9 EXECUTIVE
CHARACTER*3 TOOL
INTEGER
* DI_ECNT, !DEPTH INTERVAL SEG. ENTRY COUNT
* DF_ECNT, !DATA FORMAT SEGMENT ENRTY COUNT
* FH_ECNT,
* 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
* ENTRY_NO, !ENTRY NUMBER DATV_RDWC
* SE_FHBB,
* SE_FHBE
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
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'PROGRAM "DTV_DR_B". JP MAR.88'
WRITE(*,*)
C LESE PARAMETER_FILE:
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
CLOSE (36,STATUS='KEEP')
IF (C_AZI .EQ. 'N') THEN
L_AZI = .FALSE.
ELSE
L_AZI = .TRUE.
END IF
DECODE (3,'(F3.1)',TOOL) TYPE_OF_TOOL
IF (C_REF .EQ. 'N') THEN
L_REF = .FALSE.
ELSE
L_REF = .TRUE.
END IF
IF (C_DEC .EQ. 'N') THEN
L_DEC = .FALSE.
L_REF = .FALSE.
ELSE
L_DEC = .TRUE.
END IF
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 >ES GIBT ALSO FOLGENDE MOEGLICHKEITEN DER DARSTELLUNG:
C L_AZI ^ L_DEC = GAUSS-KRUEGER ODER N-E-S-W
C L_AZI ^ -L_DEC = N-E-S-W
C -L_AZI^ L_DEC = NUR TRUE DEPTH
C -L_AZI^-L_DEC = NUR TRUE DEPTH <
EXECUTIVE = 'BLASCHKE '
1 CONTINUE
CALL LIB$GET_LUN(UNIT_NO1)
CALL LIB$GET_LUN(UNIT_NO2)
IF (UNIT_NO1 .LT. 7 .OR. UNIT_NO2 .LT. 7) THEN
WRITE(*,*)'ERROR WITH UNIT NUMBER :',UNIT_NO1, UNIT_NO2
PAUSE 'TYPE CONTINUE OR EXIT'
GOTO 1
END IF
CALL DATV_OPEN (UNIT_NO1,FILE_NAME,'OLD',RET_STAT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_OPRO')
C.......LESE BEARBEITUNGS-SCHRITTE:
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 , 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
C.......LESE DATA_KIND:
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
IF (SE_DFKI .NE. 12) CALL RETSTAT (RET_STAT,'WRONG DATA-KIND')
DAFO_XS(1) = SE_DFXS
DAFO_YS(1) = SE_DFYS
C.......LESE ANZAHL DER BLOECKE:
DO ENTRY_NO = 1 , DI_ECNT
CALL FSHDI_SEG ('READ',RET_STAT,ENTRY_NO,
* SE_DIB,SE_DIBNB,SE_DIE,SE_DIBNE)
1000 CONTINUE
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHDI_SEG')
END DO
FBLK_BEG(1) = SE_DIBNB !ASSUME THAT THERE'S ONLY ONE ENTRY!
FBLK_END(1) = SE_DIBNE
IF (SE_FHMOD(1:3) .NE. 'DR_') THEN
C.......FORME ZU DR-DECL-FORMAT UM:
C >EINGABE DER DEKLINATION<
IF (L_DEC .AND. .NOT.L_AZI) WRITE(*,991)
IF (L_DEC .AND. .NOT.L_AZI) L_REF = .FALSE.
IF (.NOT. L_AZI) L_REF = .FALSE.
IF (L_AZI ) THEN
1211 CONTINUE
WRITE(*,1212)
1212 FORMAT (1X,'EINGABE DER MISSWEISUNG IN GRAD ',
1 '(Z.B. N4.5W BEI WESTL. MISSW.) : ',$)
READ (*,'(A8)') CMAGDECL
CALL EXT_AZI (RET_STAT,CMAGDECL,MAGDECL)
IF (RET_STAT .NE. 0) THEN
WRITE (*,992)
GOTO 1211
END IF
1214 CONTINUE
WRITE(*,1213)
1213 FORMAT (1X,'WIE GROSS IST DER FEHLER DER MIS'
1 'SWEISUNG (IN GRAD) ? ',$)
READ (*,*,ERR=1214) ERR_MAGDECL
END IF
C.......FORME ZU DR-DECL-FORMAT UM:
TYPE *,'C.......FORME ZU DR-DECL-FORMAT UM:'
L_FR = .TRUE.
FBLK_NO = FBLK_BEG(1)
DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0)
D TYPE *,'READ 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')
ROW = 0
DO WHILE (ROW .LT. DAFO_XS(1) .AND.
1 (L_FR .OR. (FB_DATA(1+ROW*DAFO_YS(1)) .NE. 0.)))
L_FR = .FALSE.
M_DEPTH = FB_DATA(1+ROW*DAFO_YS(1))
MEAS_DIP= FB_DATA(2+ROW*DAFO_YS(1))
MEAS_AZI= FB_DATA(3+ROW*DAFO_YS(1))
FB_DATA(P_TYPE_OF_TOOL+ROW*DAFO_YS(1)) = TYPE_OF_TOOL
FB_DATA(P_MAGDECL+ROW*DAFO_YS(1)) = MAGDECL
FB_DATA(P_ERR_MAGDECL+ROW*DAFO_YS(1)) = ERR_MAGDECL
FB_DATA(P_M_DEPTH+ROW*DAFO_YS(1)) = M_DEPTH
FB_DATA(P_MEAS_DIP+ROW*DAFO_YS(1)) = MEAS_DIP
FB_DATA(P_MEAS_AZI+ROW*DAFO_YS(1)) = MEAS_AZI
D TYPE *,'FB_DATA(P_TYPE_OF_TOOL) : ',
D 1 FB_DATA(P_TYPE_OF_TOOL+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_MAGDECL : ',
D 1 FB_DATA(P_MAGDECL+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_ERR_MAGDECL) : ',
D 1 FB_DATA(P_ERR_MAGDECL+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_M_DEPTH : ',
D 1 FB_DATA(P_M_DEPTH+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_MEAS_DIP+ROW : ',
D 1 FB_DATA(P_MEAS_DIP+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_MEAS_AZI+ROW : ',
D 1 FB_DATA(P_MEAS_AZI+ROW*DAFO_YS(1))
ROW = ROW + 1
END DO !WHILE
CALL DATV_WRTWC (UNIT_NO1,FBLK_NO)
FBLK_NO = F_NEXT
END DO !WHILE
END IF
C.......RECHNE
TYPE *,'C.......RECHNE'
112 CONTINUE
TYPE *,' '
TYPE *,'WAEHLE RECHENMETHODE FUER VERLAUFSRECHNUNG :'
TYPE *,'Tangential Method 1'
TYPE *,'Balanced Tangential Method 2'
TYPE *,'Angle-Averaging Method 3'
TYPE *,'Radius of Curvature 4'
TYPE *,'Minimum Curvature 5'
TYPE *,'Walstrom''s model 4 6'
C 1234567890123456789012345678901234567890
12 FORMAT (1X,A33,$)
WRITE(*,12) ' '
READ (*,*,ERR=112) IANSWER
IF (IANSWER .EQ. 1) THEN
L_TANMET = .TRUE.
FH_MOD = 'DR_TANMET'
ELSE IF (IANSWER .EQ. 2) THEN
L_BATAME = .TRUE.
FH_MOD = 'DR_BATAME'
ELSE IF (IANSWER .EQ. 3) THEN
L_ANGAVE = .TRUE.
FH_MOD = 'DR_ANGAVE'
ELSE IF (IANSWER .EQ. 4) THEN
L_RADIOC = .TRUE.
FH_MOD = 'DR_RADIOC'
ELSE IF (IANSWER .EQ. 5) THEN
L_MINICU = .TRUE.
FH_MOD = 'DR_MINICU'
ELSE IF (IANSWER .EQ. 6) THEN
L_MODEL4 = .TRUE.
FH_MOD = 'DR_MODEL4'
ELSE
GOTO 112
END IF
FBLK_NO = FBLK_BEG(1)
D TYPE *,'READ FBLK ',FBLK_NO
C DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0 .AND.
C 1 DIE .LT. M_DEPTH)
DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0)
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
IF (L_TANMET) CALL TANGE_MET
IF (L_BATAME) CALL BALAC_TA_MET
IF (L_ANGAVE) CALL ANGL_AVER
IF (L_RADIOC) CALL RADIO_CURV
IF (L_MINICU) CALL MINI_CURV
IF (L_MODEL4) CALL MODEL4
CALL DATV_WRTWC (UNIT_NO1,FBLK_NO)
FBLK_NO = F_NEXT
END DO !WHILE
C...SCHREIBE IN FILE HISTORY SEGMENT:
CALL LOG_MODULEX (UNIT_NO1,EXECUTIVE,FH_MOD,FBLK_BEG(1),FBLK_END(1))
CALL LIB$FREE_LUN(UNIT_NO1)
CALL LIB$FREE_LUN(UNIT_NO2)
220 FORMAT (/,1X,'BEREITS GELAUFENES MODUL: ',A9,/)
991 FORMAT (/,10X,
1'****DIE EINGABE DER KOMPASS-MISSWEISUNG ERUEBRIGT SICH ',
1/,10X,
1' DA IN DER VERROHUNG GEMESSEN WURDE ****')
992 FORMAT (/,1X,
1 '*** DAMIT KANN ICH NICHTS ANFANGEN, ',
1 'BITTE NOCHMAL ANDERS EINGEBEN ***',/)
END
CZ
PROGRAM DTV_DR_B
C-------SCHNELLVERSION JP 13.3.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C "FLOWCHART" :
C 1.READ TOOLTYPE
C 2.READ CORRESPONDING FILE WITH CALIBRATION PARAMETERS
C 3.READ DATA(OFFSET 0-9) AND TRANSFORM (OFFSET 10-64)
C 3A.EVENTUALLY FILTERING OF DATA
C 4.COMPUTE DIRECTIONAL SURVEY , POSSIBLE METHODS : - POLYGON
C - BALANCED TANG.
C - RADIUS OF
C CURVATURE
C 5.FILTERING AND METHOD OF DIRECTIONAL COMPUTATION
C IS WRITTEN TO FILE-HISTORY-SEGMENT (1ST BLOCK)
C JP MAR 88
C-------DECLARATION:
IMPLICIT NONE !
INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(COM_FBLK)'
INCLUDE '(LOC_FSH)'
INTEGER
1 B_NEXT,
1 F_NEXT,
1 FBLK_NO,
1 ROW,
1 UNIT_NO1,
1 UNIT_NO2,
3 D_KIND(BHT$DF_MAXE), !DATA KINDS
5 FBLK_BEG(BHT$DF_MAXE),
6 FBLK_END(BHT$DF_MAXE),
7 DIB, !DEPTH INTERVAL BEGIN
8 DIE, !" " END
3 DAFO_XS(BHT$DF_MAXE), !DATA FORMAT X SIZE
4 DAFO_YS(BHT$DF_MAXE), ! Y
5 DAFO_ZS(BHT$DF_MAXE), ! Z
6 I_FN
LOGICAL DIRECTION, !.T IF LOGGING DIRECTION FROM
C ! BOTTOM TO TOP
1 L_TANMET, !
1 L_BATAME,
1 L_RADIOC,
1 L_REF, !.T IF GAUSS-KRUEGER OUTPUT
1 L_DEC, !.T IF DECLINATION OF MAGNETIC FIELD KNOWN
1 L_AZI, !.T IF MEASURED IN OPEN HOLE
1 L_FR
REAL GHSCALE, !DEPTH SAMPLE INTERVAL
1 M_DEPTH_OLD,
1 GES_AB,
* SE_DFMIN, !MINIMUM LIMIT OF DATA
* SE_DFMAX !MAXIMUM LIMIT OF DATA
INTEGER I,J,K,
1 N, !NUMBER OF FFT SAMPLES :MAX.
5 RET_STAT,
4 IANSWER
CHARACTER*1 ANSWER,
1 C_AZI,
1 C_REF,
1 C_DEC
CHARACTER*60 FILE_NAME
CHARACTER*60 CAL_FILE_NAME
CHARACTER*10 CMAGDECL
CHARACTER*9 EXECUTIVE
CHARACTER*3 TOOL
INTEGER
* DI_ECNT, !DEPTH INTERVAL SEG. ENTRY COUNT
* DF_ECNT, !DATA FORMAT SEGMENT ENRTY COUNT
* FH_ECNT,
* 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
* ENTRY_NO, !ENTRY NUMBER DATV_RDWC
* SE_FHBB,
* SE_FHBE
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
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'PROGRAM "DTV_DR_B". JP MAR.88'
WRITE(*,*)
C LESE PARAMETER_FILE:
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
CLOSE (36,STATUS='KEEP')
IF (C_AZI .EQ. 'N') THEN
L_AZI = .FALSE.
ELSE
L_AZI = .TRUE.
END IF
DECODE (3,'(F3.1)',TOOL) TYPE_OF_TOOL
IF (C_REF .EQ. 'N') THEN
L_REF = .FALSE.
ELSE
L_REF = .TRUE.
END IF
IF (C_DEC .EQ. 'N') THEN
L_DEC = .FALSE.
L_REF = .FALSE.
ELSE
L_DEC = .TRUE.
END IF
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 >ES GIBT ALSO FOLGENDE MOEGLICHKEITEN DER DARSTELLUNG:
C L_AZI ^ L_DEC = GAUSS-KRUEGER ODER N-E-S-W
C L_AZI ^ -L_DEC = N-E-S-W
C -L_AZI^ L_DEC = NUR TRUE DEPTH
C -L_AZI^-L_DEC = NUR TRUE DEPTH <
EXECUTIVE = 'BLASCHKE '
1 CONTINUE
CALL LIB$GET_LUN(UNIT_NO1)
CALL LIB$GET_LUN(UNIT_NO2)
IF (UNIT_NO1 .LT. 7 .OR. UNIT_NO2 .LT. 7) THEN
WRITE(*,*)'ERROR WITH UNIT NUMBER :',UNIT_NO1, UNIT_NO2
PAUSE 'TYPE CONTINUE OR EXIT'
GOTO 1
END IF
CALL DATV_OPEN (UNIT_NO1,FILE_NAME,'OLD',RET_STAT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_OPRO')
C.......LESE BEARBEITUNGS-SCHRITTE:
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 , 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
C.......LESE DATA_KIND:
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
IF (SE_DFKI .NE. 12) CALL RETSTAT (RET_STAT,'WRONG DATA-KIND')
DAFO_XS(1) = SE_DFXS
DAFO_YS(1) = SE_DFYS
C.......LESE ANZAHL DER BLOECKE:
DO ENTRY_NO = 1 , DI_ECNT
CALL FSHDI_SEG ('READ',RET_STAT,ENTRY_NO,
* SE_DIB,SE_DIBNB,SE_DIE,SE_DIBNE)
1000 CONTINUE
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHDI_SEG')
END DO
FBLK_BEG(1) = SE_DIBNB !ASSUME THAT THERE'S ONLY ONE ENTRY!
FBLK_END(1) = SE_DIBNE
IF (SE_FHMOD(1:3) .NE. 'DR_') THEN
C.......FORME ZU DR-DECL-FORMAT UM:
C >EINGABE DER DEKLINATION<
IF (L_DEC .AND. .NOT.L_AZI) WRITE(*,991)
IF (L_DEC .AND. .NOT.L_AZI) L_REF = .FALSE.
IF (.NOT. L_AZI) L_REF = .FALSE.
IF (L_AZI ) THEN
1211 CONTINUE
WRITE(*,1212)
1212 FORMAT (1X,'EINGABE DER MISSWEISUNG IN GRAD ',
1 '(Z.B. N4.5W BEI WESTL. MISSW.) : ',$)
READ (*,'(A8)') CMAGDECL
CALL EXT_AZI (RET_STAT,CMAGDECL,MAGDECL)
IF (RET_STAT .NE. 0) THEN
WRITE (*,992)
GOTO 1211
END IF
1214 CONTINUE
WRITE(*,1213)
1213 FORMAT (1X,'WIE GROSS IST DER FEHLER DER MIS'
1 'SWEISUNG (IN GRAD) ? ',$)
READ (*,*,ERR=1214) ERR_MAGDECL
END IF
C.......FORME ZU DR-DECL-FORMAT UM:
TYPE *,'C.......FORME ZU DR-DECL-FORMAT UM:'
L_FR = .TRUE.
FBLK_NO = FBLK_BEG(1)
DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0)
D TYPE *,'READ 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')
ROW = 0
DO WHILE (ROW .LT. DAFO_XS(1) .AND.
1 (L_FR .OR. (FB_DATA(1+ROW*DAFO_YS(1)) .NE. 0.)))
L_FR = .FALSE.
M_DEPTH = FB_DATA(1+ROW*DAFO_YS(1))
MEAS_DIP= FB_DATA(2+ROW*DAFO_YS(1))
MEAS_AZI= FB_DATA(3+ROW*DAFO_YS(1))
FB_DATA(P_TYPE_OF_TOOL+ROW*DAFO_YS(1)) = TYPE_OF_TOOL
FB_DATA(P_MAGDECL+ROW*DAFO_YS(1)) = MAGDECL
FB_DATA(P_ERR_MAGDECL+ROW*DAFO_YS(1)) = ERR_MAGDECL
FB_DATA(P_M_DEPTH+ROW*DAFO_YS(1)) = M_DEPTH
FB_DATA(P_MEAS_DIP+ROW*DAFO_YS(1)) = MEAS_DIP
FB_DATA(P_MEAS_AZI+ROW*DAFO_YS(1)) = MEAS_AZI
D TYPE *,'FB_DATA(P_TYPE_OF_TOOL) : ',
D 1 FB_DATA(P_TYPE_OF_TOOL+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_MAGDECL : ',
D 1 FB_DATA(P_MAGDECL+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_ERR_MAGDECL) : ',
D 1 FB_DATA(P_ERR_MAGDECL+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_M_DEPTH : ',
D 1 FB_DATA(P_M_DEPTH+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_MEAS_DIP+ROW : ',
D 1 FB_DATA(P_MEAS_DIP+ROW*DAFO_YS(1))
D TYPE *,'FB_DATA(P_MEAS_AZI+ROW : ',
D 1 FB_DATA(P_MEAS_AZI+ROW*DAFO_YS(1))
ROW = ROW + 1
END DO !WHILE
CALL DATV_WRTWC (UNIT_NO1,FBLK_NO)
FBLK_NO = F_NEXT
END DO !WHILE
END IF
C.......RECHNE
TYPE *,'C.......RECHNE'
112 CONTINUE
TYPE *,' '
TYPE *,'WAEHLE RECHENMETHODE FUER VERLAUFSRECHNUNG :'
TYPE *,'Tangential Method 1'
C TYPE *,'Balanced Tangential Method 2'
C TYPE *,'Radius of Curvature 3'
C 1234567890123456789012345678901234567890
12 FORMAT (1X,A33,$)
WRITE(*,12) ' '
READ (*,*,ERR=112) IANSWER
IF (IANSWER .EQ. 1) THEN
L_TANMET = .TRUE.
FH_MOD = 'DR_TANMET'
ELSE IF (IANSWER .EQ. 2) THEN
L_BATAME = .TRUE.
FH_MOD = 'DR_BATAME'
ELSE IF (IANSWER .EQ. 3) THEN
L_RADIOC = .TRUE.
FH_MOD = 'DR_RADIOC'
ELSE
GOTO 112
END IF
FBLK_NO = FBLK_BEG(1)
D TYPE *,'READ FBLK ',FBLK_NO
C DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0 .AND.
C 1 DIE .LT. M_DEPTH)
DO WHILE (FBLK_NO .LE. FBLK_END(1) .AND. FBLK_NO .NE. 0)
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
IF (L_TANMET) CALL TANGE_MET
IF (L_BATAME) CALL BALAC_TA_MET
IF (L_RADIOC) CALL RADIO_CURV
CALL DATV_WRTWC (UNIT_NO1,FBLK_NO)
FBLK_NO = F_NEXT
END DO !WHILE
C...SCHREIBE IN FILE HISTORY SEGMENT:
CALL LOG_MODULEX (UNIT_NO1,EXECUTIVE,FH_MOD,FBLK_BEG(1),FBLK_END(1))
CALL LIB$FREE_LUN(UNIT_NO1)
CALL LIB$FREE_LUN(UNIT_NO2)
220 FORMAT (/,1X,'BEREITS GELAUFENES MODUL: ',A9,/)
991 FORMAT (/,10X,
1'****DIE EINGABE DER KOMPASS-MISSWEISUNG ERUEBRIGT SICH ',
1/,10X,
1' DA IN DER VERROHUNG GEMESSEN WURDE ****')
992 FORMAT (/,1X,
1 '*** DAMIT KANN ICH NICHTS ANFANGEN, ',
1 'BITTE NOCHMAL ANDERS EINGEBEN ***',/)
END
CZ
PROGRAM DTV_DR_LIST
C-------EXPLANATION:
C THIS PROGRAM LISTS THE DEVIATION OF WELL .
C THE PROCESSED DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA WAS FORMATTED BY THE PROGRAM ZEDA** AND PRO-
C CESSED BY DTV_DR . THE RECORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH,
C 64 DEPTH-STEPS PER BLOCK. DATA-KIND HAVE TO BE 12 !
C 'FLOWCHART:'
C 1.READ FILE HEADER
C 1A.READ FILE-HISTORY-SEGMENT ,DIRECTIONAL SURVEY , POSSIBLE METHODS :
C - TANGENTIAL ME.
C - BALANCED TANG.
C - ANGLE AVERAGE
C - RADIUS OF
C CURVATURE
C - MINIMUM CURVA.
C - WALSTROM'S M0DEL 4
C 2.IF GAUSS-KRUEGER-OUTPUT DESIRED ENTER START-COORDINATES
C 3.READ DATA FROM TOP TO BOTTOM
C JP SINCE MAR 88
C-------DECLARATION:
IMPLICIT NONE !
INCLUDE 'DR_DECL.FOR'
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(COM_FBLK)'
INCLUDE '(LOC_FSH)'
INTEGER
1 NR,
1 OFFSET_COUNTER,
1 ROW_COUNTER,
1 UNIT_NO1,
1 UNIT_NO2,
6 I_FN,
1 OUTPUT, !UNIT_NO2
1 MPS, !MEASURED POINTS
1 ROW
LOGICAL L_DIRECTION, !.T IF LOGGING DIRECTION FROM
C ! BOTTOM TO TOP
1 L_AZI, !.T IF MEASURED IN OPEN HOLE
1 L_ERROR,
1 L_REF !.T IF THERE ARE GAUSS-KRUEGER
!"TIE IN"-KOORDINATEN
REAL
1 GES_AB,
1 GES_AZI
INTEGER I,J,K,
1 N, !NUMBER OF FFT SAMPLES :MAX.
5 RET_STAT,
4 IANSWER
CHARACTER*1 ANSWER,
1 FR
CHARACTER*60 FILE_NAME
CHARACTER*3 TOOL
CHARACTER*68 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*80 BUFFER
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$GHIDENT_L) GHIDENT !FSH IDENTIFICATION
CHARACTER*(FSH$GHCRED_L) GHCRED !FILE CREATION DATE
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_ACT, !ACTUAL FILEBLOCK NUMBER
* FBLK_BEG, !FILEBLOCK NUMBER BEGIN
* FBLK_END, !FILEBLOCK NUMBER END
* 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
DOUBLE PRECISION !MP-KOORDINATEN IM GAUSS-KRUEGER-SYSTEM
1 R, !RECHTS
1 H, !HOCH
1 ZNN, !MIT Z IST HIER DIE HOEHE UEBER NN GEMEINT !!
1 Z, !WAHRE TEUFE , POSITIVE RICHTUNG NACH UNTEN
1 Y, !HIER:NORDABWEICHUNG
1 X !HIER:OSTABWEICHUNG
INTEGER KEZI !KENNZIFFER
REAL MEDI !MERIDIANKONVERGENZ IN ALGTGRAD
C.......VARIABLENNAMEN VON COMMAND_PROCEDURE :
CHARACTER*1 C_REF !J/N .TRUE. IF GAUSS-KRUEGER OUTPUT
CHARACTER*30 C_DATADIR
CHARACTER*30 C_PRINTDIR
CHARACTER*30 CALDIR
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'PROGRAM "DTV_DR_LIST". JP SINCE MAR.88'
WRITE(*,*)
C-------LESE PARAMETER_FILE:
OPEN (UNIT=36,FILE='PARAMETER',
1 STATUS='OLD')
READ (36,'(A30)') FILE_NAME
READ (36,'(A30)') TOOL
READ (36,'(A1)') C_REF
READ (36,'(A30)') C_DATADIR
READ (36,'(A30)') C_PRINTDIR
READ (36,'(A30)') CALDIR
READ (36,'(A1)')
CLOSE (36,STATUS='KEEP')
DECODE (3,'(F3.1)',TOOL) TYPE_OF_TOOL
D TYPE *,'TYPE_OF_TOOL :',TYPE_OF_TOOL
C-------SUCHE FREIE UNIT_NUMMERN:
999 CONTINUE
CALL LIB$GET_LUN(UNIT_NO1)
CALL LIB$GET_LUN(UNIT_NO2)
IF (UNIT_NO1 .LT. 7 .OR. UNIT_NO2 .LT. 7) THEN
WRITE(*,*)'ERROR WITH UNIT NUMBER :',UNIT_NO1, UNIT_NO2
PAUSE 'TYPE CONTINUE OR EXIT'
GOTO 999
END IF
C----OEFFNE DTV-FILE:
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')
C-------LESE FILE-SERVICE-HEADER:
CALL FSHGH_SEG ('READ',RET_STAT,GHIDENT,GHCRED,GHFLID,
* GHSCALE,GHNOBLKS)
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHGH_SEG')
IF (GHSCALE .LT. 0.) THEN
WRITE(*,*)'GHSCALE NEGATIV !? =< ABS'
GHSCALE = ABS(GHSCALE)
END IF
CALL FSHEC_SERV (DI_ECNT,DF_ECNT,FH_ECNT)
DO 1 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')
1 END DO
FBLK_BEG = SE_DIBNB
FBLK_END = SE_DIBNE
DO 2 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)
2 END DO
DO 3 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,'FSHDF_SERV')
3 END DO
IF (SE_DFKI .NE. 12) THEN
CALL RETSTAT (RET_STAT,'WRONG DATA_KIND')
L_ERROR = .TRUE.
END IF
IF (SE_DFXS .NE. SE_DFYS) THEN
CALL RETSTAT (RET_STAT,'WRONG DATAFORMAT')
L_ERROR = .TRUE.
END IF
IF (SE_DFXS .NE. 64) THEN
CALL RETSTAT (RET_STAT,'WRONG DATAFORMAT')
L_ERROR = .TRUE.
END IF
IF (SE_DFYS .NE. 64) THEN
CALL RETSTAT (RET_STAT,'WRONG DATAFORMAT')
L_ERROR = .TRUE.
END IF
IF(L_ERROR) CLOSE (UNIT_NO1,STATUS='KEEP')
IF(L_ERROR) GOTO 99
ROW_COUNTER = 0
C.......OEFFNE DEN AUSGABEFILE
OPEN (UNIT=UNIT_NO2,
1 FILE=C_PRINTDIR(1:INDEX(C_PRINTDIR,' ')-1)//
1 ':DTV_DR_LIST.DAT',STATUS='NEW',
1 ACCESS='SEQUENTIAL',FORM='FORMATTED',
1 CARRIAGECONTROL='LIST')
OUTPUT = UNIT_NO2
C.......EINGABE DER NAMEN,ETC,ETC
ROW_COUNTER = ROW_COUNTER + 9
WRITE(*,1100) 'BOHRUNG ? '
READ (*,'(A68)') C_BOHRUNG
WRITE (OUTPUT,7) C_BOHRUNG
LOCATION = C_BOHRUNG (1:40)
7 FORMAT (1X,T2,'Bohrung : ',A68,/)
ROW_COUNTER = ROW_COUNTER + 2
C-------STARTE ABFRAGEN:
IF (C_REF .EQ. 'J') THEN
L_REF = .TRUE.
ELSE
L_REF = .FALSE.
END IF
IF (L_REF) THEN !ENTER TIE-IN-COORDINATES
WRITE(*,*) 'EINGABE DER STARTKOORDINATEN IM GAUSS-KRUEGER SYSTEM :'
WRITE(*,1100) 'RECHTSWERT ? '
READ (*,*) R
WRITE(*,1100) 'HOCHWERT ? '
READ (*,*) H
WRITE(*,1100) 'HOEHE Z UEBER NN ? '
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
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,' ',
1'Z : ',F11.2,' m , '
1'Fehler der Koordinaten im geographischen Koordinatensystem !',/)
ROW_COUNTER = ROW_COUNTER + 4
END IF
WRITE(*,1100) 'DATUM DES MESS. ? '
READ (*,'(A68)') C_DATUM
WRITE (OUTPUT,9) C_DATUM
DATE = C_DATUM (1:40)
9 FORMAT (1X,T2,'Datum der Messung : ',A68,/)
ROW_COUNTER = ROW_COUNTER + 2
WRITE(*,1100) 'MESSTRUPP ? '
READ (*,'(A68)') C_MESSTRUPP
WRITE (OUTPUT,11) C_MESSTRUPP
11 FORMAT (1X,T2,'Messtrupp : ',A68,/)
ROW_COUNTER = ROW_COUNTER + 2
OPEN (UNIT=36,FILE='TOOLTYPE.DAT',DEFAULTFILE=CALDIR,
1 ACCESS='SEQUENTIAL',FORM='FORMATTED',STATUS='OLD')
READ (36,'(A80)') BUFFER
DO WHILE (BUFFER(5:7) .NE. TOOL)
READ (36,'(A80)') BUFFER
END DO
CLOSE (UNIT=36,STATUS='KEEP')
C_SONDE = BUFFER(13:80)
WRITE (OUTPUT,15) C_SONDE
15 FORMAT (1X,T2,'Sondentyp : ',A68,/)
ROW_COUNTER = ROW_COUNTER + 2
IF (SE_FHMOD(1:9) .EQ. 'DR_TANMET')
1C_DATENBEARBEITUNG =
1'DTV_DR ,Tangential Method'
IF (SE_FHMOD(1:9) .EQ. 'DR_BATAME')
1C_DATENBEARBEITUNG =
1'DTV_DR ,Balanced Tangential Method'
IF (SE_FHMOD(1:9) .EQ. 'DR_ANGAVE')
1C_DATENBEARBEITUNG =
1'DTV_DR ,Angle-averaging Method'
IF (SE_FHMOD(1:9) .EQ. 'DR_RADIOC')
1C_DATENBEARBEITUNG =
1'DTV_DR ,"Radius of curvature" Methode'
IF (SE_FHMOD(1:9) .EQ. 'DR_MINICU')
1C_DATENBEARBEITUNG =
1'DTV_DR ,"Minumum curvature" Methode'
IF (SE_FHMOD(1:9) .EQ. 'DR_MODEL4')
1C_DATENBEARBEITUNG =
1'DTV_DR ,Walstrom''s Modell 4 '
WRITE (OUTPUT,14) C_DATENBEARBEITUNG
14 FORMAT (1X,T2,'Datenbearbeitung : ',A68,/)
ROW_COUNTER = ROW_COUNTER + 2
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)
ENCODE (5,'(F5.1)',C_REMARK(1:5)) MAGDECL
C_REMARK =
1'Missweisung zw. geogr. und magn. Nord : '//C_REMARK(1:5)//' Grad'
WRITE (OUTPUT,16) C_REMARK
16 FORMAT (1X,T2,'Bemerkungen : ',A68)
WRITE(*,1100) 'BEMERKUNGEN : '
READ (*,'(A68)') C_REMARK
WRITE (OUTPUT,116) C_REMARK
ROW_COUNTER = ROW_COUNTER + 2
1116 CONTINUE
WRITE (*,1100) 'WEITERE BEM. (J/N)?'
READ (*,'(A1)') ANSWER
IF (ANSWER.EQ. 'J') THEN
ROW_COUNTER = ROW_COUNTER + 1
WRITE(*,1100) 'BEMERKUNGEN : '
READ (*,'(A68)') C_REMARK
WRITE (OUTPUT,116) C_REMARK
116 FORMAT (1X,T2,' ',A68)
ROW_COUNTER = ROW_COUNTER + 2
GOTO 1116
END IF
WRITE (OUTPUT,*) ' '
C >GEBE LISTENKOPF AUS<
CALL PNP_DP (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
FBLK_NO = FBLK_BEG
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
IF(TYPE_OF_TOOL .NE. FB_DATA (P_TYPE_OF_TOOL))THEN
WRITE(*,*)('**** WRONG TYPE OF TOOL IN DATA-FILE ****',I=1,10)
STOP
END IF
TYPE_OF_TOOL = FB_DATA(1)
D TYPE *,'TOOL_TYPE:',TYPE_OF_TOOL
NR = 1
FBLK_NO = FBLK_BEG
DO WHILE (FBLK_NO .LE. FBLK_END .AND. FBLK_NO .NE. 0)
D TYPE *,'READ FBLK ',FBLK_NO
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
ROW = 1
DO WHILE ((ROW .LE. SE_DFXS) .AND. (TYPE_OF_TOOL .NE. 0.))
M_DEPTH = FB_DATA (P_M_DEPTH + (ROW-1)*SE_DFYS)
ERR_DEPTH = FB_DATA (P_ERR_DEPTH + (ROW-1)*SE_DFYS)
AHD = FB_DATA (P_AHD + (ROW-1)*SE_DFYS) / DEGRAD
ERR_AHD = FB_DATA (P_ERR_AHD + (ROW-1)*SE_DFYS) / DEGRAD
DIP = FB_DATA (P_DIP + (ROW-1)*SE_DFYS) / DEGRAD
ERR_DIP = FB_DATA (P_ERR_DIP + (ROW-1)*SE_DFYS) / DEGRAD
MSZ = FB_DATA (P_MSZ + (ROW-1)*SE_DFYS)
LSZ = FB_DATA (P_LSZ + (ROW-1)*SE_DFYS)
ERR_Z = FB_DATA (P_ERR_Z + (ROW-1)*SE_DFYS)
MSY = FB_DATA (P_MSY + (ROW-1)*SE_DFYS)
LSY = FB_DATA (P_LSY + (ROW-1)*SE_DFYS)
ERR_Y = FB_DATA (P_ERR_Y + (ROW-1)*SE_DFYS)
MSX = FB_DATA (P_MSX + (ROW-1)*SE_DFYS)
LSX = FB_DATA (P_LSX + (ROW-1)*SE_DFYS)
ERR_X = FB_DATA (P_ERR_X + (ROW-1)*SE_DFYS)
C >KONVERTIERE ZU DOUBLE PREC.<
CALL EXT_2RIDP (Z,MSZ,LSZ)
CALL EXT_2RIDP (Y,MSY,LSY)
CALL EXT_2RIDP (X,MSX,LSX)
ROW_COUNTER = ROW_COUNTER + 1
D TYPE *,'ACTUAL ROW : ',ROW
IF (ROW_COUNTER .GT. 45) THEN !TOP OF FORM
C >GEBE NEUE SEITE UND LISTENKOPF AUS<
CALL PNP_DP
1 (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
END IF
IF (L_REF) CALL BL_TO_GK (Z,Y,X,MEDI,R,H,ZNN)
C >AUSGABE DER WERTE IN TABELLE<
IF (FR .NE. 'N') THEN
WRITE (OUTPUT,27)
27 FORMAT (1X,' Anschlusswerte :')
IF (L_REF)
1 WRITE (OUTPUT,2091) NR,M_DEPTH,
1 DIP,
1 AHD,
1 R,H,ZNN
2091 FORMAT(1X,T1,I3,T8,F7.2,
1 T24,F4.1,
1 T36,F5.1,
1 T51,F11.2,T72,F11.2,T93,F8.2)
IF (.NOT.L_REF)
1 WRITE (OUTPUT,2092) NR,M_DEPTH,
1 DIP,
1 AHD,
1 Z,Y,X
2092 FORMAT(1X,T2,I3,T9,F7.2,
1 T25,F4.1,
1 T38,F5.1,
1 T56,F7.2,T75,F8.2,T93,F8.2)
WRITE (OUTPUT,29)
29 FORMAT (1X,' Messwerte :')
FR = 'N'
ELSE
IF (L_REF)
1 WRITE (OUTPUT,2099) NR,M_DEPTH,ERR_DEPTH,
1 DIP,ERR_DIP,
1 AHD,ERR_AHD,
1 R,ERR_X,H,ERR_Y,ZNN,ERR_Z
2099 FORMAT(1X,T1,I3,T8,F7.2,'+-',F5.2,
1 T24,F4.1,'+-',F3.1,
1 T36,F5.1,'+-',F5.1,
1 T51,F11.2,'+-',F6.2,T72,F11.2,'+-',F6.2,T93,F8.2,'+-',F6.2)
IF (.NOT. L_REF)
1 WRITE (OUTPUT,2094) NR,M_DEPTH,ERR_DEPTH,
1 DIP,ERR_DIP,
1 AHD,ERR_AHD,
1 Z,ERR_Z,Y,ERR_Y,X,ERR_X
2094 FORMAT(1X,T2,I3,T9,F7.2,'+-',F5.2,
1 T25,F4.1,'+-',F3.1,
1 T38,F5.1,'+-',F5.1,
1 T56,F7.2,'+-',F6.2,T75,F8.2,'+-',F6.2,T93,F8.2,'+-',F6.2)
END IF
NR = NR + 1
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+(ROW-1)*SE_DFYS)
END DO !WHILE
FBLK_NO = F_NEXT
END DO !WHILE
99 CONTINUE
CLOSE (UNIT_NO1,STATUS='KEEP')
CLOSE (UNIT_NO2,STATUS='KEEP')
CALL LIB$FREE_LUN(UNIT_NO1)
CALL LIB$FREE_LUN(UNIT_NO2)
1100 FORMAT (1X,A20,$)
1101 FORMAT(1X,'KENNZAHL DES MERIDIANSTREIFENS (FAST IMMER DIE ',
1'ERSTE ZIFFER VOM RECHTSWERT) ?',/,1X,A20,$)
END
CZ
PROGRAM DTV_DR_LIST_B
C-------EXPLANATION:
C THIS PROGRAM LISTS THE DEVIATION OF WELL .
C THE PROCESSED DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA WAS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C 'FLOWCHART:'
C 1.READ FILE HEADER
C 1A.READ FILE-HISTORY-SEGMENT ,DIRECTIONAL SURVEY , POSSIBLE METHODS :
C - TANGENTIAL ME.
C - BALANCED TANG.
C - RADIUS OF
C CURVATURE
C 2.INPUT OF AUFTRAGGEBER ETC.,ETC.
C 2A.IF GAUSS-KRUEGER-OUTPUT DESIRED ENTER START-COORDINATES
C 3.READ DATA FROM TOP TO BOTTOM
C JP MAR 88 , SCHNELLVERSION FUER BLASCHKE
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 NR,
1 OFFSET_COUNTER,
1 ROW_COUNTER,
1 UNIT_NO1,
1 UNIT_NO2,
6 I_FN,
1 OUTPUT, !UNIT_NO2
1 MPS, !MEASURED POINTS
1 ROW
LOGICAL L_DIRECTION, !.T IF LOGGING DIRECTION FROM
C ! BOTTOM TO TOP
1 L_AZI, !.T IF MEASURED IN OPEN HOLE
1 L_ERROR,
1 L_REF !.T IF THERE ARE GAUSS-KRUEGER
!"TIE IN"-KOORDINATEN
REAL
1 GES_AB,
1 GES_AZI
INTEGER I,J,K,
1 N, !NUMBER OF FFT SAMPLES :MAX.
5 RET_STAT,
4 IANSWER
CHARACTER*1 ANSWER,
1 FR
CHARACTER*60 FILE_NAME
CHARACTER*3 TOOL
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*(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$GHIDENT_L) GHIDENT !FSH IDENTIFICATION
CHARACTER*(FSH$GHCRED_L) GHCRED !FILE CREATION DATE
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_ACT, !ACTUAL FILEBLOCK NUMBER
* FBLK_BEG, !FILEBLOCK NUMBER BEGIN
* FBLK_END, !FILEBLOCK NUMBER END
* 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
DOUBLE PRECISION !MP-KOORDINATEN IM GAUSS-KRUEGER-SYSTEM
1 R, !RECHTS
1 H, !HOCH
1 ZNN, !MIT Z IST HIER DIE HOEHE UEBER NN GEMEINT !!
1 Z, !WAHRE TEUFE , POSITIVE RICHTUNG NACH UNTEN
1 Y, !HIER:NORDABWEICHUNG
1 X !HIER:OSTABWEICHUNG
INTEGER KEZI !KENNZIFFER
REAL MEDI !MERIDIANKONVERGENZ IN ALGTGRAD
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*30 C_DATADIR
CHARACTER*30 C_PRINTDIR
C.......BEGIN
WRITE(*,*)
WRITE(*,*)'PROGRAM "DTV_DR_LIST_B". JP MAR.88'
WRITE(*,*)
C-------LESE PARAMETER_FILE:
OPEN (UNIT=36,FILE='PARAMETER',
1 STATUS='OLD')
READ (36,'(A30)') C_INPUT_NAME
READ (36,'(A1)') C_AZI
READ (36,'(A3)') TOOL
READ (36,'(A1)') C_REF
READ (36,'(A1)') C_DUM
READ (36,'(A30)') C_DATADIR
READ (36,'(A30)') C_PRINTDIR
CLOSE (36,STATUS='KEEP')
DECODE (3,'(F3.1)',TOOL) TYPE_OF_TOOL
D TYPE *,'TYPE_OF_TOOL :',TYPE_OF_TOOL
C-------SUCHE FREIE UNIT_NUMMERN:
999 CONTINUE
CALL LIB$GET_LUN(UNIT_NO1)
CALL LIB$GET_LUN(UNIT_NO2)
IF (UNIT_NO1 .LT. 7 .OR. UNIT_NO2 .LT. 7) THEN
WRITE(*,*)'ERROR WITH UNIT NUMBER :',UNIT_NO1, UNIT_NO2
PAUSE 'TYPE CONTINUE OR EXIT'
GOTO 999
END IF
C----OEFFNE DTV-FILE:
FILE_NAME = C_INPUT_NAME !FROM COMMAND-PROCEDURE
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 FSHGH_SEG ('READ',RET_STAT,GHIDENT,GHCRED,GHFLID,
* GHSCALE,GHNOBLKS)
IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHGH_SEG')
IF (GHSCALE .LT. 0.) THEN
WRITE(*,*)'GHSCALE NEGATIV !? =< ABS'
GHSCALE = ABS(GHSCALE)
END IF
D WRITE(6,120)GHIDENT
D WRITE(6,125)GHCRED
D WRITE(6,130)GHFLID
D WRITE(6,135)GHSCALE
D WRITE(6,140)GHNOBLKS
D WRITE(6,177)
D READ (*,*)
CALL FSHEC_SERV (DI_ECNT,DF_ECNT,FH_ECNT)
DO 1 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')
D WRITE(6,150)
D IF (DI_ECNT .GT. 1)
D * WRITE(6,155)ENTRY_NO,DI_ECNT
C_________STELLE DIE LOGGING DIRECTION FEST :
IF (SE_DIB .GT. SE_DIE) THEN
L_DIRECTION = .TRUE.
D WRITE(6,157)
ELSE
L_DIRECTION = .FALSE.
D WRITE(6,158)
END IF
D WRITE(6,160)SE_DIB
D WRITE(6,165)SE_DIE
D WRITE(6,170)SE_DIBNB
D WRITE(6,175)SE_DIBNE
D IF (DI_ECNT .GT. 1) THEN
D WRITE(6,177)
D READ (*,*)
D END IF
1 END DO
FBLK_BEG = SE_DIBNB
FBLK_END = SE_DIBNE
DO 2 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)
D IF (RET_STAT .GT. 1) CALL RETSTAT (RET_STAT,'FSHDF_SERV')
D WRITE(6,180)
D IF (DF_ECNT .GT. 1)
D * WRITE(6,155)ENTRY_NO,DF_ECNT
D WRITE(6,185)SE_DFKI
D WRITE(6,190)SE_DFXS
D WRITE(6,195)SE_DFYS
D WRITE(6,200)SE_DFZS
D WRITE(6,205)SE_DFMIN
D WRITE(6,210)SE_DFMAX
IF (DF_ECNT .GT. 1) THEN
D WRITE(6,177)
D READ (*,*)
END IF
2 END DO
DO 3 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,'FSHDF_SERV')
D WRITE(6,215)
D IF (FH_ECNT .GT. 1)
D * WRITE(6,155)ENTRY_NO,FH_ECNT
D WRITE(6,220)SE_FHMOD
D WRITE(6,225)SE_FHPAR
D WRITE(6,230)SE_FHEXE
D WRITE(6,235)SE_FHBB
D WRITE(6,240)SE_FHBE
IF (FH_ECNT .GT. 1) THEN
D WRITE(6,177)
D READ (*,*)
END IF
3 END DO
C-------STARTE ABFRAGEN:
99 CONTINUE
ANSWER = C_AZI !FROM COMMAND-PROCEDURE
IF (ANSWER .EQ. 'N') THEN
L_AZI = .FALSE.
ELSE
L_AZI = .TRUE.
END IF
IF (C_REF .EQ. 'N') THEN
L_REF = .FALSE.
ELSE
IF (L_AZI) L_REF = .TRUE.
END IF
IF (SE_FHMOD(1:9) .EQ. 'DR_TANMET')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_DR_LIST_B ,Tangenten Methode'
IF (SE_FHMOD(1:9) .EQ. 'DR_BATAME')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_DR_LIST_B ,Balanced Tangential Method'
IF (SE_FHMOD(1:9) .EQ. 'DR_ANGAVE')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_DR_LIST_B ,Angle-averaging Method'
IF (SE_FHMOD(1:9) .EQ. 'DR_RADIOC')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_DR_LIST_B ,"Radius of curvature" Methode'
IF (SE_FHMOD(1:9) .EQ. 'DR_MINICU')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_DR_LIST_B ,"Minumum curvature" Methode'
IF (SE_FHMOD(1:9) .EQ. 'DR_MODEL4')
1C_DATENBEARBEITUNG =
1'DTV_DR_B,DTV_DR_LIST_B ,Walstrom''s Modell 4 '
IF (SE_DFKI .NE. 12) THEN
CALL RETSTAT (RET_STAT,'WRONG DATA_KIND')
L_ERROR = .TRUE.
END IF
IF (SE_DFXS .NE. SE_DFYS) THEN
CALL RETSTAT (RET_STAT,'WRONG DATAFORMAT')
L_ERROR = .TRUE.
END IF
IF (SE_DFXS .NE. 64) THEN
CALL RETSTAT (RET_STAT,'WRONG DATAFORMAT')
L_ERROR = .TRUE.
END IF
IF (SE_DFYS .NE. 64) THEN
CALL RETSTAT (RET_STAT,'WRONG DATAFORMAT')
L_ERROR = .TRUE.
END IF
IF(L_ERROR) CLOSE (UNIT_NO1,STATUS='KEEP')
IF(L_ERROR) GOTO 99
C.......OEFFNE DEN AUSGABEFILE
OPEN (UNIT=UNIT_NO2,FILE='DTV_DR_LIST.DAT',STATUS='NEW',
1 ACCESS='SEQUENTIAL',FORM='FORMATTED',
1 CARRIAGECONTROL='LIST',
1 DEFAULTFILE=C_PRINTDIR(1:INDEX(C_PRINTDIR,' ')-1)//':')
OUTPUT = UNIT_NO2
C.......GEBE KOPFZEILE AUS: !! JEZT VIA COMMANDOPROZEDUR !!
C CALL PRINT_HEAD_DP (RET_STAT,'TRILOG',OUTPUT,ROW_COUNTER)
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 !ENTER TIE-IN-COORDINATES
WRITE(*,*) 'EINGABE DER STARTKOORDINATEN IM GAUSS-KRUEGER SYSTEM :'
WRITE(*,1100) 'RECHTSWERT ? '
READ (*,*) R
WRITE(*,1100) 'HOCHWERT ? '
READ (*,*) H
WRITE(*,1100) 'HOEHE Z UEBER NN ? '
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
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,' ',
1'Z : ',F11.2,' m (ueber NN)',/)
ROW_COUNTER = ROW_COUNTER + 4
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,/)
FBLK_NO = FBLK_BEG
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
TYPE_OF _TOOL = FB_DATA (P_TYPE_OF_TOOL)
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,'Sondentyp : ',A58,/)
WRITE(*,1100) 'AUSWERTER ? '
READ (*,'(A58)') C_AUSWERTER
WRITE (OUTPUT,13) C_AUSWERTER
13 FORMAT (1X,T2,'Auswerter : ',A58,/)
WRITE (OUTPUT,14) C_DATENBEARBEITUNG
14 FORMAT (1X,T2,'Datenbearbeitung : ',A58,/)
IF (L_AZI) THEN
C >LESE MISSWEISUNG EIN<
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) / .9 !ALTGRAD-<GON
ENCODE (5,'(F5.1)',C_REMARK(1:5)) MAGDECL
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 (L_AZI) WRITE (OUTPUT,116) C_REMARK
IF (.NOT.L_AZI) 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 + 21
CALL PRINT_SCHEDULE_HEAD_DP (RET_STAT,OUTPUT,ROW_COUNTER,L_REF)
TYPE_OF_TOOL = FB_DATA(1)
D TYPE *,'TOOL_TYPE:',TYPE_OF_TOOL
NR = 1
FBLK_NO = FBLK_BEG
DO WHILE (FBLK_NO .LE. FBLK_END .AND. FBLK_NO .NE. 0)
D TYPE *,'READ FBLK ',FBLK_NO
CALL DATV_RDWC (RET_STAT,UNIT_NO1,FBLK_NO,B_NEXT,F_NEXT)
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'DATV_RDWC')
ROW = 0
DO WHILE ((ROW .LT. SE_DFXS) .AND. (TYPE_OF_TOOL .NE. 0.))
M_DEPTH = FB_DATA (P_M_DEPTH + ROW*SE_DFYS)
DEPTH = FB_DATA (P_DEPTH + ROW*SE_DFYS)
AZI = FB_DATA (P_AZI + ROW*SE_DFYS) / DEGRAD
DIP = FB_DATA (P_DIP + ROW*SE_DFYS) / DEGRAD
MSZ = FB_DATA (P_MSZ + ROW*SE_DFYS)
LSZ = FB_DATA (P_LSZ + ROW*SE_DFYS)
MSY = FB_DATA (P_MSY + ROW*SE_DFYS)
LSY = FB_DATA (P_LSY + ROW*SE_DFYS)
MSX = FB_DATA (P_MSX + ROW*SE_DFYS)
LSX = FB_DATA (P_LSX + ROW*SE_DFYS)
CALL EXT_2RIDP (Z,MSZ,LSZ)
CALL EXT_2RIDP (Y,MSY,LSY)
CALL EXT_2RIDP (X,MSX,LSX)
ROW_COUNTER = ROW_COUNTER + 1
D TYPE *,'ACTUAL ROW : ',ROW
IF (ROW_COUNTER .GT. 60) THEN !TOP OF FORM
ROW_COUNTER = 0
CALL PRINT_NEW_PAGE_DP
1 (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
END IF
IF (L_REF) CALL BL_TO_GK (Z,Y,X,MEDI,R,H,ZNN)
C >AUSGABE DER WERTE IN TABELLE<
IF (FR .NE. 'N') THEN
WRITE (OUTPUT,27)
27 FORMAT (1X,' Anschlusswerte :')
IF (L_AZI .AND. L_REF)
1 WRITE (OUTPUT,209) NR,M_DEPTH, DIP, AZI , R,H,ZNN
IF (.NOT.L_AZI .AND. L_REF)
1 WRITE (OUTPUT,208) NR,M_DEPTH, DIP ,DEPTH
IF (L_AZI .AND. .NOT.L_REF)
1 WRITE (OUTPUT,2099) NR,M_DEPTH, DIP, AZI , DEPTH,
1 Y,X
IF (.NOT.L_AZI .AND. .NOT.L_REF)
1 WRITE (OUTPUT,2088) NR,M_DEPTH, DIP ,DEPTH
WRITE (OUTPUT,29)
29 FORMAT (1X,' Messwerte :')
FR = 'N'
ELSE
IF (L_AZI .AND. L_REF)
1 WRITE(OUTPUT,209) NR , M_DEPTH, DIP, AZI ,R,H,ZNN
IF (.NOT. L_AZI .AND. L_REF)
1 WRITE(OUTPUT,208) NR, M_DEPTH, DIP, DEPTH
IF (L_AZI .AND. .NOT. L_REF)
1 WRITE(OUTPUT,2099) NR , M_DEPTH, DIP, AZI ,DEPTH,Y,X
IF (.NOT. L_AZI .AND. .NOT.L_REF)
1 WRITE(OUTPUT,2088) NR, M_DEPTH, DIP, DEPTH
END IF
NR = NR + 1
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+ROW*SE_DFYS)
END DO !WHILE
FBLK_NO = F_NEXT
END DO !WHILE
C DAS ALTE REAL-FORMAT:
C208 FORMAT (1X,T2,I3,T10,F7.2,T21,F4.1, T50,F7.2)
C209 FORMAT (1X,T2,I3,T10,F7.2,T21,F4.1,T35,F5.1,T50,F7.2)
C1200 FORMAT (1X,T2,I3,T10,F7.2,T21,F4.1, T50,F7.2
C 1 T88,F7.2)
C1210 FORMAT (1X,T2,I3,T10,F7.2,T21,F4.1,T35,F5.1,T50,F7.2,T63,F7.2,
C 1 T73,F7.2,T88,F7.2,T104,F4.0)
C DAS NEUE DOUBLE PRECISION "HOCH"-FORMAT(MIT PRINT_SCHEDULE_HEAD_DP)
209 FORMAT(1X,T2,I3,T8,F7.2,T18,F4.1,T28,F5.1,
1 T36,F11.2,T50,F11.2,T64,F11.2)
208 FORMAT(1X,T1,I3,T8,F7.2,T18,F4.1,
1 T36,F7.2)
2099 FORMAT(1X,T1,I3,T8,F7.2,T18,F4.1,T28,F5.1,
1 T36,F7.2, T50,F11.2,T64,F11.2)
2088 FORMAT(1X,T1,I3,T8,F7.2,T18,F4.1,
1 T36,F7.2)
1100 FORMAT (1X,A20,$)
1101 FORMAT(1X,'KENNZAHL DES MERIDIANSTREIFENS (FAST IMMER DIE ',
1'ERSTE ZIFFER VOM RECHTSWERT) ?',/,1X,A20,$)
CLOSE (UNIT_NO1,STATUS='KEEP')
CLOSE (UNIT_NO2,STATUS='KEEP')
CALL LIB$FREE_LUN(UNIT_NO1)
CALL LIB$FREE_LUN(UNIT_NO2)
CZ
C_______FORMATANWEISUNGEN:(AUS FBLK_BEG_END_X)
100 FORMAT(1X,//)
105 FORMAT ('$','PLEASE ENTER FILENAME : ')
110 FORMAT(A30)
115 FORMAT(/,1X,'---------FILE SERVICE HEADER----------',/)
120 FORMAT (1X,'FSH IDENTIFIKATION : ',A30)
125 FORMAT (1X,'FILE CREATION DATE : ',A30)
130 FORMAT (1X,'FILE IDENTIFICATION NUMBER : ',I8)
135 FORMAT (1X,'DATA SCALE (MM) : ',
1 F8.2)
140 FORMAT (1X,'LAST FILE BLOCK : ',I8)
150 FORMAT(/,1X,'--------DEPTH INTERVAL SEGMENT--------',/)
155 FORMAT (1X,I2,'. ENTRY OF ',I2,' ENTRIES.')
157 FORMAT (1X,'--<LOGGING DIRECTION FROM BOTTOM TO TOP',/)
158 FORMAT (1X,'--<LOGGING DIRECTION FROM TOP TO BOTTOM',/)
160 FORMAT (1X,'DEPTH INTERVAL BEGIN (MM) : ',I8)
165 FORMAT (1X,'DEPTH INTERVAL END (MM) : ',I8)
170 FORMAT (1X,'DEPTH INTERVAL BLOCK NUMBER BEGIN : ',I8)
175 FORMAT (1X,'DEPTH INTERVAL BLOCK NUMBER END : ',I8)
177 FORMAT(/,1X,'PLEASE PRESS >RETURN< TO CONTINUE !')
180 FORMAT(/,1X,'----------DATA FORMAT SEGMENT---------',/)
185 FORMAT (1X,'KIND OF DATA : ',I8)
190 FORMAT (1X,'X - SIZE : ',I8)
195 FORMAT (1X,'Y - SIZE : ',I8)
200 FORMAT (1X,'Z - SIZE : ',I8)
205 FORMAT (1X,'MINIMAL DATA VALUE : ',F15.8)
210 FORMAT (1X,'MAXIMAL DATA VALUE : ',F15.8)
215 FORMAT(/,1X,'---------FILE HISTORY SEGMENT---------',/)
220 FORMAT (1X,'ALREADY USED MODULE : '
1 ,A30)
225 FORMAT(1X,'MODULE PARAMETER FILE : '
1 ,A30)
230 FORMAT (1X,'EXECUTIVE : ',A30)
235 FORMAT (1X,'MODULE EXECUTION BLOCK BEGIN : ',I8)
240 FORMAT (1X,'MODULE EXECUTION BLOCK END : ',I8)
242 FORMAT(/,'$','DO YOU WANNA LOOK AT THE FIELD SERVICE HEADER'
1 ,' (Y/DEF=N) ? ')
243 FORMAT(A1)
245 FORMAT(/,1X,'INTERVAL INPUT - FIRST TYPE B MEANING ',
1 'FILE_BLOCKS :',
2 /,1X,' (TYPE R WHEN REPEAT FILE-INFORMATON)')
250 FORMAT ('$','DESIRED INTERVAL BEGIN (MM) ? ')
255 FORMAT(A9)
260 FORMAT ('$','DESIRED INTERVAL END (MM) ? ')
265 FORMAT ('$','DESIRED DATA_KIND ? ')
270 FORMAT(I3)
272 FORMAT(1X,'NO SUCH DATA_KIND !')
273 FORMAT(//,1X,80('*'),
1 /,1X,'ERROR: FILEBLOCK DOESNOT MATCH WITH DESIRED DATA_KIND',
2 /,1X,' ==< ENTER NEW DEPTHINTERVAL.',
3 /,1X,80('*'))
280 FORMAT(I1)
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_AZI (RET_STAT,CAZI,RAZI)
C DIESE SUBROUTINE WIRD VON MULTISHOT_INPUT AUFGERUFEN.
C EINGABE Z.B. N81.5W WIRD ZU 278.5 GEWANDELT, ODER
C N0 WIRD ZU 0. GEWANDELT.
C ES GIBT EIN TEST-PROGRAMM HIERZU : T_EXT_AZI.EXE
C JP MAR88
IMPLICIT NONE !!
INTEGER I,
1 RET_STAT,
1 LEN_C,
1 LEN_R
REAL RAZI
CHARACTER*10 CAZI
CHARACTER*1 CBUFF
LOGICAL L_QUADRANT,
1 L_POINT
RET_STAT = -1
L_QUADRANT = .FALSE.
LEN_C = INDEX(CAZI,' ') -1
C.......STELLE FEST OB UEBERHAUPT RICHTIG
C IF ((CAZI(1:1) .EQ. 'N') .EQV. (CAZI(1:1) .EQ. 'S') .EQV.
C 1 (CAZI(1:1) .EQ. 'W') .EQV. (CAZI(1:1) .EQ. 'O') .EQV.
C 1 (CAZI(1:1) .EQ. 'E') ) RETURN
IF (.NOT.((CAZI(1:1) .EQ. 'N') .OR.
1 (CAZI(1:1) .EQ. 'S') .OR.
1 (CAZI(1:1) .EQ. 'O') .OR.
1 (CAZI(1:1) .EQ. 'E') .OR.
1 (CAZI(1:1) .EQ. 'W'))) RETURN
IF (LEN_C .LT. 1) RETURN
C.......LIEGT DER WINKEL IM QUADRANTEN ?
I = LEN_C
IF (CAZI(I:I) .EQ. 'E' .OR.
1 CAZI(I:I) .EQ. 'W' .OR.
1 CAZI(I:I) .EQ. 'O') L_QUADRANT = .TRUE.
C.......WINKEL LIEGT NICHT IM QUADRANTEN, -< 0. ODER 180. ODER 90. ODER 270.GRAD
IF (.NOT. L_QUADRANT) THEN
IF (LEN_C .EQ. 1 .AND. CAZI(1:1) .EQ. 'N') THEN
RAZI = 0.
RET_STAT = 0
END IF
IF (LEN_C .EQ. 1 .AND. CAZI(1:1) .EQ. 'S') THEN
RAZI = 180.
RET_STAT = 0
END IF
END IF
IF (L_QUADRANT) THEN
IF (LEN_C .EQ. 1) THEN
IF (CAZI(1:1) .EQ. 'W') THEN
RAZI = 270.
RET_STAT = 0
END IF
IF (CAZI(1:1) .EQ. 'E') THEN
RAZI = 90.
RET_STAT = 0
END IF
IF (CAZI(1:1) .EQ. 'O') THEN
RAZI = 90.
RET_STAT = 0
END IF
ELSE
C.........SUCHE DEN ZAHLENTEIL:
L_POINT = .FALSE.
I = 2
DO WHILE (I .LE. LEN_C-1 .AND.
1 (ICHAR(CAZI(I:I)) .EQ. 46 .OR. !.
1 ICHAR(CAZI(I:I)) .EQ. 48 .OR. !0
1 ICHAR(CAZI(I:I)) .EQ. 49 .OR. !1
1 ICHAR(CAZI(I:I)) .EQ. 50 .OR. !2
1 ICHAR(CAZI(I:I)) .EQ. 51 .OR. !3
1 ICHAR(CAZI(I:I)) .EQ. 52 .OR. !4
1 ICHAR(CAZI(I:I)) .EQ. 53 .OR. !5
1 ICHAR(CAZI(I:I)) .EQ. 54 .OR. !6
1 ICHAR(CAZI(I:I)) .EQ. 55 .OR. !7
1 ICHAR(CAZI(I:I)) .EQ. 56 .OR. !8
1 ICHAR(CAZI(I:I)) .EQ. 57)) !9
IF (ICHAR(CAZI(I:I)) .EQ. 46) L_POINT = .TRUE.
I = I + 1
END DO !WHILE
C.........UNGUELTIGER BUCHSTABE:
D IF (I .NE. LEN_C) TYPE *,'I .NE. LEN_C'
IF (I .NE. LEN_C) RETURN
IF (.NOT. L_POINT) THEN
C.........FUEGE DEZIMALPUNKT EIN:
CBUFF = CAZI (LEN_C:LEN_C)
CAZI(LEN_C:LEN_C) = '.'
LEN_C = LEN_C + 1
CAZI(LEN_C:LEN_C) = CBUFF
END IF
D TYPE *,'WANDLE UM: ',CAZI(2:LEN_C-1)
LEN_R = LEN_C - 2
11 FORMAT (F7.4)
DECODE (LEN_R, 11, CAZI(2:(LEN_C-1)) , ERR=999 ) RAZI
C.........TESTE OB 0. > ZAHLENBEREICH >= 90. :
IF (RAZI .LT. 0.000001) RETURN
IF (RAZI .GT. 90.00001) RETURN
I = LEN_C
C.........ADDIERE NOCH DIE QUADRANTEN DRAUF :
IF (CAZI(1:1) .EQ. 'N' .AND. CAZI(I:I) .EQ. 'O') RAZI = RAZI
IF (CAZI(1:1) .EQ. 'N' .AND. CAZI(I:I) .EQ. 'E') RAZI = RAZI
IF (CAZI(1:1) .EQ. 'S' .AND. CAZI(I:I) .EQ. 'O') RAZI = 180. - RAZI
IF (CAZI(1:1) .EQ. 'S' .AND. CAZI(I:I) .EQ. 'E') RAZI = 180. - RAZI
IF (CAZI(1:1) .EQ. 'S' .AND. CAZI(I:I) .EQ. 'W') RAZI = RAZI + 180.
IF (CAZI(1:1) .EQ. 'N' .AND. CAZI(I:I) .EQ. 'W') RAZI = 360. - RAZI
RET_STAT = 0
END IF
END IF
999 CONTINUE
RETURN
END
SUBROUTINE EXT_DPI2R (DX,MSX,LSX)
C This subroutine EXTracts from a Double Precision value 2 Real values.
C JP MAR88
IMPLICIT NONE !
DOUBLE PRECISION DX,
1 A
REAL MSX,LSX
C BEGIN:
MSX = SNGL(DX-DMOD(DX,1.D3))
LSX = SNGL(DMOD(DX,1.D3))
D WRITE(*,*) 'MSX :',MSX
D WRITE(*,*) 'LSX :',LSX
D WRITE(*,*) 'SETZE WIEDER ZUSAMMEN :'
D A = DBLE(MSX) + DBLE(LSX)
D WRITE(*,*) A
C END;
RETURN
END
C*****************************************************************************C
C C
C SUBROUTINE L O G _ M O D U L E X C
C C
C*****************************************************************************C
SUBROUTINE LOG_MODULEX (UNIT_NO,EXECUTIVE,FH_MOD,FBLK_BEG,FBLK_END)
IMPLICIT NONE
C_DESCRIPTION
C
C Log module subroutine
C The task of this subroutine is to log the requested modules in the
C file history segment. All the other
C necessary information is transfered by the actual parameters of this
C subroutine.
C Caution: Keep in mind that this routine uses the common file block
C unit COM_FBLK, so the data previously stored in this unit will be
C destroyed after routine return.
C
C Author: Joachim Faulhaber IGL: 13.12.85
C SIMPLFIZIERT VON JP AM 13.3.88
C_PARAMETERS
C UNIT_NO - Unit number of the file, whose file history segment
C should be updated. (I4 input)
C
C EXECUTIVE - Name of the executive who starts the modules (string9)
C_INCLUSIONS
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(LOC_FSH)'
INCLUDE '(COM_FBLK)'
C INCLUDE '(COM_MDCB)'
C INCLUDE '(COM_WDCB)'
C INCLUDE '(COM_DKCB)'
C_CONSTANTS
INTEGER*2 FSH ! File service header number
PARAMETER ( FSH = 1 )
C_VARIABLES
INTEGER UNIT_NO, ! parameter
1 B_NEXT, ! only needed for subroutine call
2 F_NEXT, ! only needed for subroutine call
3 RET_STAT, ! subroutine return status
4 ENTRY_NO, ! only needed for subroutine call
5 INDEX, ! index
1 FBLK_BEG,
1 FBLK_END
CHARACTER*(*) EXECUTIVE ! parameter
CHARACTER*30 TIME ! actual time
CHARACTER FH_PAR_C*(FSH$FHPAR_L) ! ASCII equivalent to FH_PAR
C_SUBROUTINES
C DATV_RDWC ! read a file block into COM_FBLK
C FSHFH_SEG ! file service header FH-segment access routine
C DATV_WRTWC ! write data in COM_FBLK to the file
C SYS$ASCTIM ! system service routine provided by VMS
C_END_DECLARATION
C -------------------------------------------------------------------
C Store file service header environment in the common file block unit
C -------------------------------------------------------------------
CALL SYS$ASCTIM (,TIME,,)
CALL DATV_RDWC (RET_STAT,UNIT_NO,FSH,B_NEXT,F_NEXT)
C ---------------------------------------------------------------------
C Update the file history segment by transfering the information of the
C module control block to the common file block unit.
C ---------------------------------------------------------------------
FH_EXE = EXECUTIVE(:FSH$FHPAR_L)
FH_DAT = TIME(:FSH$FHDAT_L)
FH_BB = FBLK_BEG
FH_BE = FBLK_END
C >log each module listed in the module control block<
CALL FSHFH_SEG ('APPEND',RET_STAT,ENTRY_NO,
2 FH_MOD,FH_PAR,FH_EXE,FH_DAT,FH_BB,FH_BE)
CALL DATV_WRTWC (UNIT_NO,FSH)
RETURN
END
SUBROUTINE MINI_CURV
C-------SCHNELLVERSION JP 5.5.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C COORDINATES ARE COMPUTED IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH START-POINT (0.,0.,0) !
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 ROW
REAL
1 M_DEPTH_OLD,
1 DIP_OLD,
1 AZI_OLD,
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DELTA_DEPTH,
1 K, !CORRECTION-VALUE
1 TANK !TAN(K/2.)/K
DOUBLE PRECISION
1 REF_Z, !START-COORDINATES
1 REF_Y,
1 REF_X,
1 Z, !MP-COORDINATES
1 Y,
1 X
CHARACTER*1 FIRST_RUN
LOGICAL L_BALA_MET !.TRUE. IF DIP AND AZIMUTH DON'T CHANGE
C BEGIN:
ROW = 0
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
DO WHILE (ROW .LT. DR$X_SIZE .AND.
1 TYPE_OF_TOOL .NE. 0)
D TYPE *,'COMPUTE ROW NO.',ROW+1,' MAX: ',DR$X_SIZE
IF (FIRST_RUN .NE. 'N') THEN
D TYPE *,'FIRST_RUN MINI_CURV'
C >GET REFERENCE COORDINATES FROM START-POINT<
MSZ = FB_DATA(P_MSZ)
MSZ = FB_DATA(P_LSZ)
CALL EXT_2RIDP (REF_Z,MSZ,MSZ)
MSY = FB_DATA(P_MSY)
MSY = FB_DATA(P_LSY)
CALL EXT_2RIDP (REF_Y,MSY,MSY)
MSX = FB_DATA(P_MSX)
MSX = FB_DATA(P_LSX)
CALL EXT_2RIDP (REF_X,MSX,MSX)
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FIRST_RUN = 'N'
ELSE
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
COURSE_LEN = M_DEPTH - M_DEPTH_OLD
M_DEPTH_OLD = M_DEPTH
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
END IF
K = ACOS (COS(DIP-DIP_OLD)-
1 2*SIN(DIP_OLD)*SIN(DIP)*
1 (SIN((AZI_OLD-AZI)/2.)**2.))
IF (ABS(K) .LT. .1E-05) L_BALA_MET = .TRUE.
D IF (L_BALA_MET) TYPE *,'USE BALANCED TANGENTIAL METHOD'
D IF (.NOT.L_BALA_MET) TYPE *,'USE MINIMUM CURVATURE METHOD'
IF (.NOT. L_BALA_MET) THEN
TANK = TAN(K/2.)/K
DELTA_DEPTH = COURSE_LEN * TANK*(COS(DIP)+COS(DIP_OLD))
DEPTH = DEPTH + DELTA_DEPTH
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN * TANK *
1 (SIN(DIP)*COS(AZI)+SIN(DIP_OLD)*COS(AZI_OLD))) + Y
X = DBLE(COURSE_LEN * TANK *
1 (SIN(DIP_OLD)*SIN(AZI_OLD)+SIN(DIP)*SIN(AZI))) + X
ELSE
DELTA_DEPTH = COURSE_LEN/2. * (COS(DIP)+COS(DIP_OLD))
DEPTH = DEPTH + DELTA_DEPTH
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*COS(AZI)+SIN(DIP_OLD)*COS(AZI_OLD))) + Y
X = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*SIN(AZI)+SIN(DIP_OLD)*SIN(AZI_OLD))) + X
L_BALA_MET = .FALSE.
END IF
C >CONVERT DOUBLE PRECISION INTO TWO REAL VALUES<
CALL EXT_DPI2R (Z,MSZ,LSZ)
CALL EXT_DPI2R (Y,MSY,LSY)
CALL EXT_DPI2R (X,MSX,LSX)
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FB_DATA (P_DEPTH+ROW*DR$Y_SIZE) = DEPTH
FB_DATA (P_DIP+ROW*DR$Y_SIZE) = DIP
FB_DATA (P_AZI+ROW*DR$Y_SIZE) = AZI
FB_DATA (P_MSZ+ROW*DR$Y_SIZE) = MSZ
FB_DATA (P_LSZ+ROW*DR$Y_SIZE) = LSZ
FB_DATA (P_MSY+ROW*DR$Y_SIZE) = MSY
FB_DATA (P_LSY+ROW*DR$Y_SIZE) = LSY
FB_DATA (P_MSX+ROW*DR$Y_SIZE) = MSX
FB_DATA (P_LSX+ROW*DR$Y_SIZE) = LSX
D TYPE *,'DEPTH :',DEPTH
D TYPE *,'DIP :',DIP
D TYPE *,'AZI :',AZI
D TYPE *,'MSZ :',MSZ
D TYPE *,'LSZ :',LSZ
D TYPE *,'MSY :',MSY
D TYPE *,'LSY :',LSY
D TYPE *,'MSX :',MSX
D TYPE *,'LSX :',LSX
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+ROW*DR$Y_SIZE)
END DO !WHILE
C END;
RETURN
END
SUBROUTINE MODEL4
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL USING WALSTROMS "MODEL4" (1972).
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C COORDINATES ARE COMPUTED IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH START-POINT (0.,0.,0) !
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 ROW
REAL
1 M_DEPTH_OLD,
1 DIP_OLD,
1 AZI_OLD,
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DELTA_DEPTH,
1 ZAEHLER1,ZAEHLER2,ZAEHLER3,ZAEHLER4,
1 NENNER1,NENNER2,NENNER3
DOUBLE PRECISION
1 REF_Z, !START-COORDINATES
1 REF_Y,
1 REF_X,
1 Z, !MP-COORDINATES
1 Y,
1 X
CHARACTER*1 FIRST_RUN
C BEGIN:
ROW = 0
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
DO WHILE (ROW .LT. DR$X_SIZE .AND.
1 TYPE_OF_TOOL .NE. 0)
D TYPE *,'COMPUTE ROW NO.',ROW+1,' MAX: ',DR$X_SIZE
IF (FIRST_RUN .NE. 'N') THEN
D TYPE *,'FIRST_RUN TANGE_MET'
C >GET REFERENCE COORDINATES FROM START-POINT<
MSZ = FB_DATA(P_MSZ)
MSZ = FB_DATA(P_LSZ)
CALL EXT_2RIDP (REF_Z,MSZ,MSZ)
MSY = FB_DATA(P_MSY)
MSY = FB_DATA(P_LSY)
CALL EXT_2RIDP (REF_Y,MSY,MSY)
MSX = FB_DATA(P_MSX)
MSX = FB_DATA(P_LSX)
CALL EXT_2RIDP (REF_X,MSX,MSX)
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
DEPTH = COURSE_LEN * COS(DIP) + DEPTH
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FIRST_RUN = 'N'
ELSE
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
C IF (M_DEPTH .NE. 0.) THEN !NOT FIRST RUN
COURSE_LEN = M_DEPTH - M_DEPTH_OLD
M_DEPTH_OLD = M_DEPTH
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
ERR_DIP = FB_DATA(P_ERR_DIP+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
END IF
ZAEHLER1 = DIP-AZI+DIP_OLD-AZI_OLD
ZAEHLER2 = DIP-AZI-DIP_OLD+AZI_OLD
ZAEHLER3 = DIP+AZI+DIP_OLD+AZI_OLD
ZAEHLER4 = DIP+AZI-DIP_OLD-AZI_OLD
NENNER1 = ZAEHLER2
NENNER2 = ZAEHLER4
NENNER3 = DIP-DIP_OLD
IF (ABS(NENNER3) .LT. ERR_DIP .OR.
1 ABS(NENNER3) .LT. .1E-20) THEN
DELTA_DEPTH = COURSE_LEN * COS ((DIP+DIP_OLD)/2.)
ELSE
DELTA_DEPTH = COURSE_LEN *
1 ((SIN(DIP)-SIN(DIP_OLD))/NENNER3)
END IF
DEPTH = DEPTH + DELTA_DEPTH
Z = DBLE(DELTA_DEPTH) + Z
IF (ABS(NENNER1) .LT. .1E-10 .OR.
1 ABS(NENNER2) .LT. .1E-10) THEN
D TYPE *,'NENNER1 OR 2 TOO SMALL -< BALANCED TANGENTIAL METHOD'
Y = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*COS(AZI)+SIN(DIP_OLD)*COS(AZI_OLD))) + Y
X = DBLE(COURSE_LEN/2. *
1 (SIN(DIP)*SIN(AZI)+SIN(DIP_OLD)*SIN(AZI_OLD))) + X
ELSE
D TYPE *,'NORMAL EXEC'
Y = DBLE(COURSE_LEN *
1 ((SIN(ZAEHLER3/2.)*SIN(ZAEHLER4/2.))/NENNER2 +
2 (SIN(ZAEHLER1/2.)*SIN(ZAEHLER2/2.))/NENNER1)) + Y
X = DBLE(COURSE_LEN *
1 ((COS(ZAEHLER1/2.)*SIN(ZAEHLER2/2.))/NENNER1 -
2 (COS(ZAEHLER3/2.)*SIN(ZAEHLER4/2.))/NENNER2)) + X
END IF
C >CONVERT DOUBLE PRECISION INTO TWO REAL VALUES<
CALL EXT_DPI2R (Z,MSZ,LSZ)
CALL EXT_DPI2R (Y,MSY,LSY)
CALL EXT_DPI2R (X,MSX,LSX)
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FB_DATA (P_DEPTH+ROW*DR$Y_SIZE) = DEPTH
FB_DATA (P_DIP+ROW*DR$Y_SIZE) = DIP
FB_DATA (P_AZI+ROW*DR$Y_SIZE) = AZI
FB_DATA (P_MSZ+ROW*DR$Y_SIZE) = MSZ
FB_DATA (P_LSZ+ROW*DR$Y_SIZE) = LSZ
FB_DATA (P_MSY+ROW*DR$Y_SIZE) = MSY
FB_DATA (P_LSY+ROW*DR$Y_SIZE) = LSY
FB_DATA (P_MSX+ROW*DR$Y_SIZE) = MSX
FB_DATA (P_LSX+ROW*DR$Y_SIZE) = LSX
D TYPE *,'DEPTH :',DEPTH
D TYPE *,'DIP :',DIP
D TYPE *,'AZI :',AZI
D TYPE *,'MSZ :',MSZ
D TYPE *,'LSZ :',LSZ
D TYPE *,'MSY :',MSY
D TYPE *,'LSY :',LSY
D TYPE *,'MSX :',MSX
D TYPE *,'LSX :',LSX
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+ROW*DR$Y_SIZE)
END DO !WHILE
C END;
RETURN
END
PROGRAM MULTISHOT_INPUT_B
C SCHNELLVERSION EXTRA FUER HERRN BLASCHKE
C EINGABE FUER MULTISHOT_CHANGE_AZIMUT . JP MAR 88
C ES WERDEN EINGEGEBEN TEUFE Z.B. 100
C NEIGUNG Z.B. 5.5
C AZIMUT Z.B. N81.5W
C DIE ABFRAGEN VON AZIMUT J/N UND FILENAME SIND SCHON IN DER KOMMANDOPROZEDUR ERFOLGT !
C DER AZIMUT WIRD MIT SUBROUTINE EXT_AZI UMGEWANDELT , Z.B. N81.5W -< 278.5
C.......VARIABLENLISTE:
IMPLICIT NONE
INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
REAL TEUFE,NEIGUNG,AZIMUT
CHARACTER*30 FILENAME
CHARACTER*10 CAZI,
1 LEER
INTEGER RET_STAT
C-------EINGABEVARIABLEN VON KOMMANDOPROZEDUR :
CHARACTER*30 C_INPUT_NAME
CHARACTER*3 TOOLTYPE
CHARACTER*1 C_AZI
LOGICAL L_AZI
C.......BEGIN:
DATA LEER/' '/
WRITE(*,*)
WRITE(*,*)' ---------------'
WRITE(*,*)' MULTISHOT_INPUT'
WRITE(*,*)' ---------------'
WRITE(*,*)
WRITE(*,*)'VERSION 1.0 JP MAR 88'
WRITE(*,*)
WRITE(*,19)
C LESE PARAMETER_FILE:
OPEN (UNIT=36,FILE='PARAMETER',
1 STATUS='OLD')
READ (36,'(A30)') FILENAME
READ (36,'(A1)') C_AZI
READ (36,'(A3)') TOOLTYPE
9 CLOSE (36,STATUS='KEEP')
DECODE (3,'(F3.1)',TOOLTYPE) TYPE_OF_TOOL
IF (C_AZI .EQ. 'N') THEN
L_AZI = .FALSE.
ELSE
L_AZI = .TRUE.
END IF
D WRITE(*,*) FILENAME
D WRITE(*,*) L_AZI
C.......OEFFNE DATENFILE:
OPEN (UNIT=37,FILE=FILENAME//'.DAT',DEFAULTFILE='DTV$DATA:',
1 STATUS='NEW')
WRITE(*,*)
WRITE(*,*) 'EINLESEN VON TEUFE IN METERN'
WRITE(*,*) ' DIP IN GRAD'
IF (L_AZI) WRITE(*,*)
1' AZIMUT IN GRAD (z.B. N11.1W , S5E oder N)'
WRITE(*,*)
WRITE(*,*) 'AM ENDE DER EINGABE TEUFE : >ENTER<'
WRITE(*,*) ' DIP : >ENTER<'
IF (L_AZI)
1WRITE(*,*) ' AZIMUT: >ENTER<'
WRITE(*,*)
C.......EINLESEN DER DATEN:
TEUFE = -1.
DO WHILE (TEUFE .NE. 0. .OR.
1 NEIGUNG .NE. 0. .OR.
1 CAZI .NE. LEER)
WRITE(*,*)
100 CONTINUE
WRITE(*,10) 'TEUFE ? '
READ (*,'(F8.0)',ERR=1000) TEUFE
GOTO 101
1000 CONTINUE
WRITE(*,99)
WRITE(*,10) 'WIEDERHOLUNG DER TEUFEN EINGABE : '
READ (*,'(F8.0)',ERR=1000) TEUFE
101 CONTINUE
WRITE(*,10) 'NEIGUNG ? '
READ (*,'(F8.0)',ERR=1010) NEIGUNG
GOTO 102
1010 CONTINUE
WRITE(*,99)
WRITE(*,10) 'WIEDERHOLUNG DER DIP EINGABE : '
READ (*,'(F8.0)',ERR=1010) NEIGUNG
102 CONTINUE
IF (L_AZI) THEN
WRITE(*,10) 'AZIMUT ? '
READ (*,'(A10)') CAZI
RET_STAT = 0
C.......WANDLE AZIMUT IN REALZAHL UM:
CALL EXT_AZI(RET_STAT,CAZI,AZIMUT)
DO WHILE (RET_STAT .NE. 0 .AND. CAZI .NE. LEER)
WRITE(*,99)
WRITE(*,10) 'WIEDERHOLUNG DER AZIMUT EINGABE : '
READ (*,'(A10)') CAZI
RET_STAT = 0
CALL EXT_AZI(RET_STAT,CAZI,AZIMUT)
END DO !WHILE
ELSE
CAZI = LEER
END IF !(L_AZI)
C >ANDERS GEHT'S Z.ZT. LEIDER NICHT !<
! IF (RET_STAT .EQ. 0 .AND. CAZI .NE. LEER) THEN
IF (RET_STAT .EQ. 0 ) THEN
WRITE (37,*) TEUFE
WRITE (37,*) NEIGUNG
WRITE (37,*) AZIMUT
END IF
END DO !WHILE
WRITE(*,*) 'ENDE DER EINGABE.'
C.......SCHLIESSE DATENFILE:
ENDFILE (37)
CLOSE (37,STATUS='KEEP')
STOP
19 FORMAT (1X,80('-'),/,1X,T10,
1'ACHTUNG , DIE NEIGUNGSWERTE ',
1'SIND VON DER VERTIKALEN AUS ANZUGEBEN !',/,
11X,'D.H. BEI MESSUNGEN IM LIEGENDEN KOENNEN DIE WERTE ',
1'-JE NACH PENDELEINSATZ-',
1/,1X,'ZWISCHEN 0 UND 90 GRAD LIEGEN, BEI MESSUNGEN IN ',
1'HANGENDEN ZWISCHEN 90 UND 180',
1/,1X,'GRAD, MESSUNGEN IN HORIZONTALBOHRUNGEN ZWISCHEN 60 ',
1'UND 120 GRAD',
1/,1X,80('-'),/)
99 FORMAT (1X,80('*'),/,1X,T30,
1 '==========< EINGABEFEHLER >==========',
1 /,1X,80('*'))
10 FORMAT (1X,A50,$)
END
CZ
SUBROUTINE PNP_DP
1 (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
C-------EXPLANATION:
C THIS PROGRAM IS A PART OF THE PROGRAM DTV_DR_LIST , IT LISTS THE DEVIATION OF
C WELL . THE OUTPUT-FILE IS ALREADY OPENED BY MAIN-PROGRAM.
C JP SINCE MAR 88
C-------DECLARATION:
IMPLICIT NONE !
INTEGER
1 PAGE_NUMBER,
1 RET_STAT,
1 ROW_COUNTER,
1 OUTPUT !UNIT_NO2
LOGICAL L_REF !.TRUE. IF GAUSS-KRUEGER-OUTPUT
CHARACTER*40 LOCATION,
1 DATE
CHARACTER*1 FIRST_RUN
BYTE FF
SAVE FIRST_RUN
SAVE PAGE_NUMBER
DATA FF /12/
C.......BEGIN:
IF (FIRST_RUN .NE. 'N') THEN
PAGE_NUMBER = 1
FIRST_RUN = 'N'
ELSE
WRITE (OUTPUT,55,IOSTAT=RET_STAT) FF
WRITE (OUTPUT,555,IOSTAT=RET_STAT) PAGE_NUMBER,LOCATION,DATE
IF (RET_STAT .NE. 0) CALL RETSTAT (RET_STAT,'PRINT_NEW_PAGE')
ROW_COUNTER = 2
END IF
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 + 9
17 FORMAT (1X,110('='),/)
19 FORMAT (1X,T1,' LFD.',
1 T11,'MESS-',
2 T24,'NEIGUNG',
1 T37,'AZIMUT',
1 T74,'KOORDINATEN')
21 FORMAT (1X,T1,' NR.',
1 T11,'TEUFE',
1 T24,' (DIP)',
1 T37,'(GEOG)',
1 T58,'R',
1 T79,'H',
1 T97,'Z')
23 FORMAT (1X,T1,' ',
1 T11,' m',
1 T24,' grad',
1 T37,' grad',
1 T58,'m',
1 T79,'m',
1 T97,'m')
25 FORMAT (1X,110('-'))
119 FORMAT (1X,T1,' LFD.',
1 T12,'MESS-',
2 T25,'NEIGUNG',
1 T39,'AZIMUT',
1 T59,'WAHRE',
1 T86,'KOORDINATEN')
121 FORMAT (1X,T1,' NR.',
1 T12,'TEUFE',
1 T25,' (DIP)',
1 T39,'(GEOG)',
1 T59,'TEUFE',
1 T80,'+N/-S',
1 T98,'+E/-W')
123 FORMAT (1X,T1,' ',
1 T12,' m',
1 T25,' grad',
1 T39,' grad',
1 T59,' m',
1 T80,' m',
1 T98,' m')
PAGE_NUMBER = PAGE_NUMBER + 1
C END;
RETURN
55 FORMAT (A1)
555 FORMAT (/,1X,'Seite ',I2,T12,A40,1X,A40)
END
CZ
SUBROUTINE PRINT_HEAD_DP (RET_STAT,DRUCKER,UNIT,ZEILENZAEHLER)
C SUBROUTINE FUER DTV_DR_LIST.
C DIESE SUBROUTINE DRUCKT DEN HEADER FETT UND GROESSER FUER FOLGENDE DRUCKER :
C -TRILOG
C -LA100,LA210
C DER OPEN BEFEHL MUSS ...,CARRIAGECONTROL='LIST',... ENTHALTEN !!!
C AENDERUNG GEGENUEBER PRINT_HEAD: NUN LAENGSFORMAT UND VOLLE KOORDINATENAUSGABE
C JP MAR 88
IMPLICIT NONE
CHARACTER*6 DRUCKER !'TRILOG' ODER 'LAXXXX'
INTEGER UNIT, !AUSGABEFILE UNIT
1 I,
1 RET_STAT,
1 ZEILENZAEHLER
CHARACTER*1 BIG, !GROSSSCHRIFT !NUR TRILOG
1 BIGLA, !BREITSCHRIFT !NUR LAXXXX
1 SML, !KLEINSCHRIFT !NUR LAXXXX
1 CR, !CARRIDGE RETURN
1 FF, !FORM FEED
1 LF !LINE FEED
BYTE HD(5), !HIGH DENSITY LETTER MODE
1 MD(5) !MEDIUM " " "
BYTE
1 CPI5(4), !5 CHARACTERS PER INCH
1 CPI10(4), !10 CHARACTERS PER INCH
1 LPI2(5), !2 LINES PER INCH
1 LPI4(5) !4 LINES PER INCH
DATA BIG/8/
DATA CR/13/
DATA FF/12/
DATA LF/10/
DATA HD /27,'[','3','"','z'/
DATA MD /27,'[','2','"','z'/
DATA CPI5 /27,'[','5','w'/
DATA CPI10 /27,'[','1','w'/
C.......GEBE KOPFZEILE AUS:
WRITE (UNIT,111,IOSTAT=RET_STAT) FF
WRITE (UNIT,111,IOSTAT=RET_STAT) CR,LF,CR,LF,CR,LF
IF (DRUCKER .EQ. 'TRILOG') THEN
WRITE (UNIT,112,IOSTAT=RET_STAT) BIG,'-----------',BIG,CR
WRITE (UNIT,112,IOSTAT=RET_STAT) BIG,'W B K - M C',BIG,CR
WRITE (UNIT,112,IOSTAT=RET_STAT) BIG,'-----------',BIG,CR
WRITE (UNIT,113,IOSTAT=RET_STAT) BIG,'VERLAUFSMESSUNG',BIG,CR
WRITE (UNIT,111,IOSTAT=RET_STAT) LF
ZEILENZAEHLER = ZEILENZAEHLER + 13
END IF !TRILOG
IF (DRUCKER .EQ. 'LAXXXX') THEN
WRITE (UNIT,211,IOSTAT=RET_STAT) HD
WRITE (UNIT,211,IOSTAT=RET_STAT) LPI2
WRITE (UNIT,2111,IOSTAT=RET_STAT) CPI5
WRITE (UNIT,212,IOSTAT=RET_STAT) '-----------',CR
WRITE (UNIT,212,IOSTAT=RET_STAT) 'W B K - M C',CR
WRITE (UNIT,212,IOSTAT=RET_STAT) '-----------',CR
WRITE (UNIT,113,IOSTAT=RET_STAT) 'VERLAUFSMESSUNG',CR
WRITE (UNIT,211,IOSTAT=RET_STAT) MD
WRITE (UNIT,2111,IOSTAT=RET_STAT) CPI10
WRITE (UNIT,111,IOSTAT=RET_STAT) LF
ZEILENZAEHLER = ZEILENZAEHLER + 10
END IF !LAXXXX
RETURN
111 FORMAT (6A1)
112 FORMAT (A1,T8,A40,A1,A1)
113 FORMAT (A1,T10,A40,A1)
211 FORMAT (5A1,A4,A4)
2111 FORMAT (5A1)
212 FORMAT (T12,A40,A1)
213 FORMAT (T10,A40,A1)
END
SUBROUTINE PRINT_NEW_PAGE_DP
1 (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
C-------EXPLANATION:
C THIS PROGRAM IS A PART OF THE PROGRAM DTV_DR_LIST , IT LISTS THE DEVIATION OF
C WELL . THE OUTPUT-FILE IS ALREADY OPENED BY MAIN-PROGRAM
C JP MAR 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 PRINT_SCHEDULE_HEAD_DP (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,T10,A40,1X,A40)
END
CZ
SUBROUTINE PRINT_SCHEDULE_HEAD_DP
1 (RET_STAT,OUTPUT,ROW_COUNTER,L_REF)
C-------EXPLANATION:
C THIS PROGRAM IS A PART OF THE PROGRAM DTV_DR_LIST , IT LISTS THE DEVIATION OF
C WELL . THE OUTPUT-FILE IS ALREADY OPENED BY MAIN-PROGRAM.
C THE DIFFERENCE TO PRINT_SCHEDULE_HEAD IS THE DOUBLE-PRECISION-OUTPUT FROM
C Z,Y,AND X-COORDINATES.
C JP MAR 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,' LFD.',
1 T8,'MESS-',
2 T16,'NEIGUNG',
1 T27,'AZIMUT',
1 T50,'KOORDINATEN')
21 FORMAT (1X,T1,' NR.',
1 T8,'TEUFE',
1 T16,' ',
1 T27,'(MAGN)',
1 T41,'R',
1 T55,'H',
1 T69,'Z')
23 FORMAT (1X,T1,' ',
1 T8,' m',
1 T16,' grad',
1 T27,' grad',
1 T41,'m',
1 T55,'m',
1 T69,'m')
25 FORMAT (1X,75('-'))
119 FORMAT (1X,T1,' LFD.',
1 T8,'MESS-',
2 T16,'NEIGUNG',
1 T27,'AZIMUT',
1 T40,'WAHRE',
1 T58,'KOORDINATEN')
121 FORMAT (1X,T1,' NR.',
1 T8,'TEUFE',
1 T16,' ',
1 T27,'(MAGN)',
1 T40,'TEUFE',
1 T55,'+N/-S',
1 T67,'+E/-W')
123 FORMAT (1X,T1,' ',
1 T8,' m',
1 T16,' grad',
1 T27,' grad',
1 T42,'m',
1 T57,'m',
1 T69,'m')
END
CZ
SUBROUTINE RADIO_CURV
C-------SCHNELLVERSION JP 6.4.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C COORDINATES ARE COMPUTED IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH START-POINT (0.,0.,0) !
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 ROW
REAL
1 M_DEPTH_OLD,
1 DIP_OLD,
1 AZI_OLD,
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DELTA_DEPTH,
1 DIPDIFF,
1 AZIDIFF,
1 NENNER
DOUBLE PRECISION
1 REF_Z, !START-COORDINATES
1 REF_Y,
1 REF_X,
1 Z, !MP-COORDINATES
1 Y,
1 X
CHARACTER*1 FIRST_RUN
C BEGIN:
ROW = 0
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
DO WHILE (ROW .LT. DR$X_SIZE)
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+ROW*DR$Y_SIZE)
IF (TYPE_OF_TOOL .GT. 0.) THEN
D TYPE *,'COMPUTE ROW NO.',ROW+1,' MAX: ',DR$X_SIZE
IF (FIRST_RUN .NE. 'N') THEN
D TYPE *,'FIRST_RUN radio_curv_met'
C >GET REFERENCE COORDINATES FROM START-POINT<
MSZ = FB_DATA(P_MSZ)
MSZ = FB_DATA(P_LSZ)
CALL EXT_2RIDP (REF_Z,MSZ,MSZ)
MSY = FB_DATA(P_MSY)
MSY = FB_DATA(P_LSY)
CALL EXT_2RIDP (REF_Y,MSY,MSY)
MSX = FB_DATA(P_MSX)
MSX = FB_DATA(P_LSX)
CALL EXT_2RIDP (REF_X,MSX,MSX)
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
DEPTH = COURSE_LEN * COS(DIP) + DEPTH
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FIRST_RUN = 'N'
ELSE
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
COURSE_LEN = M_DEPTH - M_DEPTH_OLD
M_DEPTH_OLD = M_DEPTH
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
END IF
DIPDIFF = DIP - DIP_OLD
AZIDIFF = AZI - AZI_OLD
NENNER = DIPDIFF * AZIDIFF
IF (DIPDIFF .NE. 0.) THEN
DELTA_DEPTH = COURSE_LEN * (SIN(DIP)-SIN(DIP_OLD)) /
1 DIPDIFF
ELSE
DELTA_DEPTH = COURSE_LEN * COS (DIP)
END IF
DEPTH = DEPTH + DELTA_DEPTH
Z = DBLE(DELTA_DEPTH) + Z
IF (NENNER .NE. 0.) THEN
Y = DBLE(COURSE_LEN * (COS(DIP_OLD)-COS(DIP)) *
1 (SIN(AZI)-SIN(AZI_OLD)) / NENNER ) + Y
X = DBLE(COURSE_LEN * (COS(DIP_OLD)-COS(DIP)) *
1 (COS(AZI_OLD)-COS(AZI)) / NENNER ) + X
ELSE
Y = DBLE(COURSE_LEN * SIN((DIP_OLD+DIP)/2.) *
1 COS((AZI+AZI_OLD)/2.) ) + Y
X = DBLE(COURSE_LEN * SIN((DIP_OLD+DIP)/2.) *
1 SIN((AZI+AZI_OLD)/2.) ) + X
END IF
C >CONVERT DOUBLE PRECISION INTO TWO REAL VALUES<
CALL EXT_DPI2R (Z,MSZ,LSZ)
CALL EXT_DPI2R (Y,MSY,LSY)
CALL EXT_DPI2R (X,MSX,LSX)
DIP_OLD = DIP
AZI_OLD = AZI
END IF
FB_DATA (P_DEPTH+ROW*DR$Y_SIZE) = DEPTH
FB_DATA (P_DIP+ROW*DR$Y_SIZE) = DIP
FB_DATA (P_AZI+ROW*DR$Y_SIZE) = AZI
FB_DATA (P_MSZ+ROW*DR$Y_SIZE) = MSZ
FB_DATA (P_LSZ+ROW*DR$Y_SIZE) = LSZ
FB_DATA (P_MSY+ROW*DR$Y_SIZE) = MSY
FB_DATA (P_LSY+ROW*DR$Y_SIZE) = LSY
FB_DATA (P_MSX+ROW*DR$Y_SIZE) = MSX
FB_DATA (P_LSX+ROW*DR$Y_SIZE) = LSX
D TYPE *,'DEPTH :',DEPTH
D TYPE *,'DIP :',DIP
D TYPE *,'AZI :',AZI
D TYPE *,'MSZ :',MSZ
D TYPE *,'LSZ :',LSZ
D TYPE *,'MSY :',MSY
D TYPE *,'LSY :',LSY
D TYPE *,'MSX :',MSX
D TYPE *,'LSX :',LSX
ROW = ROW + 1
END IF
END DO !WHILE
C END;
RETURN
END
PROGRAM T
C TESTET DOUBLE PRECISION IN ZWEI INTEGER:
DOUBLE PRECISION Z,A
REAL MSZ,LSZ
WRITE (*,*)' Z? '
READ (*,*) Z
MSZ = SNGL(Z-DMOD(Z,1.D3))
LSZ = SNGL(DMOD(Z,1.D3))
WRITE(*,*) 'MSZ :',MSZ
WRITE(*,*) 'LSZ :',LSZ
WRITE(*,*) 'SETZE WIEDER ZUSAMMEN :'
A = DBLE(MSZ) + DBLE(LSZ)
WRITE(*,*) A
STOP
END
SUBROUTINE TANGE_MET
C-------SCHNELLVERSION JP 13.3.88
C-------EXPLANATION:
C THIS PROGRAM COMPUTES THE DEVIATION OF WELL .
C THE ROW DATA IS STORED IN A FILE. THE FILE MUST HAVE THE SAME ATTRIBUTES
C LIKE DTV_FILES. NORMALY THE DATA IS FORMATTED BY THE PROGRAM ZEDA2A . THE RE-
C CORDLENGTH IS 4096 LONGWORDS, 64 VALUES PER DEPTH, 64 DEPTH-STEPS PER BLOCK.
C DATA-KIND HAVE TO BE 12 !
C COORDINATES ARE COMPUTED IN THE GEOGRAFICAL COORDINATE-SYSTEM WITH START-POINT (0.,0.,0) !
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 ROW
REAL
1 M_DEPTH_OLD,
1 COURSE_LEN, !MEASURED DIFFERENCE BETWEEN LAST ANS ACTUAL MP
1 DELTA_DEPTH
DOUBLE PRECISION
1 REF_Z, !START-COORDINATES
1 REF_Y,
1 REF_X,
1 Z, !MP-COORDINATES
1 Y,
1 X
CHARACTER*1 FIRST_RUN
C BEGIN:
ROW = 0
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL)
DO WHILE (ROW .LT. DR$X_SIZE .AND.
1 TYPE_OF_TOOL .NE. 0)
D TYPE *,'COMPUTE ROW NO.',ROW+1,' MAX: ',DR$X_SIZE
IF (FIRST_RUN .NE. 'N') THEN
D TYPE *,'FIRST_RUN TANGE_MET'
C >GET REFERENCE COORDINATES FROM START-POINT<
MSZ = FB_DATA(P_MSZ)
MSZ = FB_DATA(P_LSZ)
CALL EXT_2RIDP (REF_Z,MSZ,MSZ)
MSY = FB_DATA(P_MSY)
MSY = FB_DATA(P_LSY)
CALL EXT_2RIDP (REF_Y,MSY,MSY)
MSX = FB_DATA(P_MSX)
MSX = FB_DATA(P_LSX)
CALL EXT_2RIDP (REF_X,MSX,MSX)
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
DEPTH = COURSE_LEN * COS(DIP) + DEPTH
END IF
FIRST_RUN = 'N'
ELSE
M_DEPTH = FB_DATA(P_M_DEPTH+ROW*DR$Y_SIZE)
IF (M_DEPTH .NE. 0.) THEN !NOT FIRST RUN
COURSE_LEN = M_DEPTH - M_DEPTH_OLD
M_DEPTH_OLD = M_DEPTH
MAGDECL = FB_DATA(P_MAGDECL+ROW*DR$Y_SIZE)
MEAS_DIP= FB_DATA(P_MEAS_DIP+ROW*DR$Y_SIZE)
MEAS_AZI= FB_DATA(P_MEAS_AZI+ROW*DR$Y_SIZE)
IF (INT(FB_DATA(1)) .EQ. 4) THEN !MULTISHOT
DIP = MEAS_DIP * DEGRAD
AZI = (MEAS_AZI + MAGDECL) * DEGRAD
IF (AZI .LT. 0.) AZI = AZI + 2.*PI
IF (AZI .GE. 2.*PI) AZI = AZI - 2.*PI
END IF
DELTA_DEPTH = COURSE_LEN * COS(DIP)
DEPTH = DEPTH + DELTA_DEPTH
Z = DBLE(DELTA_DEPTH) + Z
Y = DBLE(COURSE_LEN*SIN(DIP)*COS(AZI)) + Y
X = DBLE(COURSE_LEN*SIN(DIP)*SIN(AZI)) + X
C >CONVERT DOUBLE PRECISION INTO TWO REAL VALUES<
CALL EXT_DPI2R (Z,MSZ,LSZ)
CALL EXT_DPI2R (Y,MSY,LSY)
CALL EXT_DPI2R (X,MSX,LSX)
END IF
END IF
FB_DATA (P_DEPTH+ROW*DR$Y_SIZE) = DEPTH
FB_DATA (P_DIP+ROW*DR$Y_SIZE) = DIP
FB_DATA (P_AZI+ROW*DR$Y_SIZE) = AZI
FB_DATA (P_MSZ+ROW*DR$Y_SIZE) = MSZ
FB_DATA (P_LSZ+ROW*DR$Y_SIZE) = LSZ
FB_DATA (P_MSY+ROW*DR$Y_SIZE) = MSY
FB_DATA (P_LSY+ROW*DR$Y_SIZE) = LSY
FB_DATA (P_MSX+ROW*DR$Y_SIZE) = MSX
FB_DATA (P_LSX+ROW*DR$Y_SIZE) = LSX
D TYPE *,'DEPTH :',DEPTH
D TYPE *,'DIP :',DIP
D TYPE *,'AZI :',AZI
D TYPE *,'MSZ :',MSZ
D TYPE *,'LSZ :',LSZ
D TYPE *,'MSY :',MSY
D TYPE *,'LSY :',LSY
D TYPE *,'MSX :',MSX
D TYPE *,'LSX :',LSX
ROW = ROW + 1
TYPE_OF_TOOL = FB_DATA(P_TYPE_OF_TOOL+ROW*DR$Y_SIZE)
END DO !WHILE
C END;
RETURN
END
PROGRAM T_DBLE
C TESTET DOUBLE PRECISION IN ZWEI INTEGER:
DOUBLE PRECISION Z,A
REAL MSZ,LSZ
WRITE (*,*)' Z? '
READ (*,*) Z
MSZ = SNGL(Z-DMOD(Z,1.D3))
LSZ = SNGL(DMOD(Z,1.D3))
WRITE(*,*) 'MSZ :',MSZ
WRITE(*,*) 'LSZ :',LSZ
WRITE(*,*) 'SETZE WIEDER ZUSAMMEN :'
A = DBLE(MSZ) + DBLE(LSZ)
WRITE(*,*) A
STOP
END
PROGRAM T_PRINT_SCHEDULE_DP
C TEST PRINT_HEAD_DP,PRINT_NEW_PAGE_DP,PRINT_SCHEDULE_HEAD_DP
IMPLICIT NONE
CHARACTER*1 ANSWER
CHARACTER*6 DRUCKER !'TRILOG' ODER 'LAXXXX'
CHARACTER*40 DATE,
1 LOCATION
CHARACTER*80 C80
CHARACTER*58 C58
INTEGER UNIT_NO, !AUSGABEFILE UNIT
1 OUTPUT,
1 RET_STAT,
1 ROW_COUNTER,
1 SIDE_NUMBER
LOGICAL L_PAGE,
1 L_REF
WRITE(*,*)'N-E-S-W ODER R-H-Z (F/T) ?'
READ (*,'(L1)') L_REF
WRITE(*,*)'T)RILOG ODER L)AXXXX DRUCKER ?'
READ (*,'(A1)') ANSWER
IF (ANSWER .EQ. 'T') DRUCKER = 'TRILOG'
IF (ANSWER .EQ. 'L') DRUCKER = 'LAXXXX'
UNIT_NO = 55
OUTPUT = UNIT_NO
C.......OEFFNE DEN AUSGABEFILE
WRITE(*,*) 'OPEN TP.DAT'
OPEN (UNIT=55,FILE='TP.DAT',STATUS='NEW',
1 ACCESS='SEQUENTIAL',FORM='FORMATTED',
1 CARRIAGECONTROL='LIST',SHARED)
CALL PRINT_HEAD_DP (RET_STAT,DRUCKER,UNIT_NO,ROW_COUNTER)
C.......EINGABE DER AUFTRAGGEBER ETC,ETC
WRITE(*,100) 'AUFTRAGGEBER ? '
100 FORMAT (1X,A20,$)
READ (*,'(A58)') C58
WRITE (OUTPUT,5) C58
5 FORMAT (1X,T1,'Auftraggeber : ',A58,/)
C 1234567890123456789012
WRITE(*,100) 'BOHRUNG ? '
READ (*,'(A58)') C58
WRITE (OUTPUT,7) C58
LOCATION = C58 (1:40)
7 FORMAT (1X,T1,'Bohrung : ',A58,/)
WRITE(*,100) 'DATUM DES MESS. ? '
READ (*,'(A58)') C58
WRITE (OUTPUT,9) C58
DATE = C58 (1:40)
9 FORMAT (1X,T1,'Datum der Messung : ',A58,/)
WRITE(*,100) 'MESSTRUPP ? '
READ (*,'(A58)') C58
WRITE (OUTPUT,11) C58
11 FORMAT (1X,T1,'Messtrupp : ',A58,/)
WRITE(*,100) 'SONDENTYP ? '
READ (*,'(A58)') C58
WRITE (OUTPUT,12) C58
12 FORMAT (1X,T1,'Sondentyp : ',A58,/)
WRITE(*,100) 'AUSWERTER ? '
READ (*,'(A58)') C58
WRITE (OUTPUT,13) C58
13 FORMAT (1X,T1,'Auswerter : ',A58,/)
WRITE(*,100) 'DATENBEARBEITUNG ? '
READ (*,'(A80)') C58
WRITE (OUTPUT,15) C58
15 FORMAT (1X,T1,'Datenbearbeitung : ',A58,//)
CALL PRINT_SCHEDULE_HEAD_DP (RET_STAT,OUTPUT,ROW_COUNTER,L_REF)
WRITE(*,'(//,A20,$)') 'NEW PAGE (T/F) ? '
READ (*,'(L1)') L_PAGE
IF (L_PAGE) CALL PRINT_NEW_PAGE_DP
1 (RET_STAT,OUTPUT,LOCATION,DATE,ROW_COUNTER,L_REF)
CLOSE (OUTPUT)
END
CZ
PROGRAM ZEDA_B
C DIESES PROGRAMM ERMOEGLICHT DIE EINGABE VON ZAHLEN INS DTV SYSTEM
C SCHNELLVERSION FUER BLASCHKE, AENDERUNGEN : BEI OPEN DEFAULTFILE AUF DTV$DATA:
C GEAENDERTES DSKHEADWRT-PROGRAM OHNE DEPTH_END EINGABE
IMPLICIT NONE
REAL FB_DATA_SCR(4096), !DATAFILEBLOCK ,WHICH CONTAIN ONLY 4096
C ! DATA IN STANDARD DTV-FORMAT.
1 DEPTH_BEG,
2 DEPTH_END,
3 DEPTH_INT
INTEGER VALUE_CNT, !THE NUMBER OF DATA IN ONE BLOCK,(IN THIS
!PROGRAM THERE IS 4096 DATA).
1 DATA_KIND, !THE KIND OF DATA ,(IN THEIS PROGRAM ONLY
!THE AMPLITUDES ARE REPRESENTED).
1 FILE_ID, !THE MANNER OF DATARECORD,(IN THIS PROGRAM
!THE DATA ARE SYNTHETIC).
1 UNIT_IN, !INPUTUNITNUMBER,(IN THIS PROGRAM IT HAS
!THE VALUE "0").
1 I,
1 J,
1 K,
1 EA_STATUS,
1 RET_STAT,
1 MPS !COUNTS MEASURE-POINTS
INTEGER*2 X_SIZE, !THE NUMBER OF DATA IN ONE REVOLUTION.
1 Y_SIZE, !THE NUMBER OF REVOLUTIONS IN ONE DATA-
C !BLOCK.
2 INC !INCREMENT OF THE DATA INPUT FILE
LOGICAL FIH_SWITCH, !IT HAS ALWAYS THE LOGICAL VALUE"FALSE"
1 FUNCNAME,
2 EOF,
3 L_SCREEN
CHARACTER *12 FUNC !IT HAS THREE FUNCTIONS,"OPEN" THE FILE,
!"WRITE"THE FILE,AND "CLOSE"THE FILE.
CHARACTER*30 FILNAM, !THE NAME OF THE OUTPUTFILE.
1 DATAFILNAM
CHARACTER*1 CHAR
C
C-----------DATA INPUT ----------------
C
TYPE *,' '
TYPE *,' ------'
TYPE *,' ZEDA_B'
TYPE *,' ------'
TYPE *,' '
TYPE *,'THIS PROGRAM TRANSVERS ANY REALNUMBERS TO DTV-FORMAT'
TYPE *,'THE INPUT DATA FILE HAVE TO BE =< SEQUENTIAL, '
TYPE *,' =< UNFORMATTED,'
TYPE *,' =< CONTAIN AN EOF MARK '
TYPE *,' '
TYPE *,'ONE DATABLOCK CONTAINS 4096 DATAPOINTS, STORED IN A'
TYPE *,'TWO DIMENSIONAL ARRAY (X_SIZE,Y_SIZE).'
TYPE *,'YOU HAVE TO CREATE MORE THAN ONE DATABLOCK ! ',
1 'FOR EXAMPLE :'
TYPE *,'THERE ARE 1500 DATAPOINTS ,CHOOSE Y_SIZE=4 TO CREATE ',
1 'AN ARRAY (1024,4) AND TWO DATABLOCKS.'
TYPE *,' Y_SIZE ?'
ACCEPT *,Y_SIZE
X_SIZE = 4096/Y_SIZE
TYPE *,' X_SIZE = ',X_SIZE
TYPE *,'DEPTH_BEG ?'
ACCEPT *,DEPTH_BEG
TYPE *,'DEPTH_INT ?'
ACCEPT *,DEPTH_INT
C TYPE *,'DEPTH_END ?'
C ACCEPT *,DEPTH_END
TYPE *,'DATA_KIND ?'
ACCEPT *,DATA_KIND
TYPE *,'FILE_ID ?'
ACCEPT *,FILE_ID
TYPE *,'DTV FILENAME ?'
ACCEPT 13,FILNAM
FILNAM = FILNAM//'.DTV'
TYPE *,'DTV FILENAME : ',FILNAM
TYPE *,'WHAT''S THE COMPLET NAME OF THE DATA INPUT FILE ?'
ACCEPT 13,DATAFILNAM
13 FORMAT (A30)
TYPE *,'DATAFILNAM : ',DATAFILNAM
15 CONTINUE
TYPE *,'WHAT''S THE INCREMENT OF THIS DATA FILE ?'
ACCEPT *,INC
IF (INC .GT. Y_SIZE) GOTO 15
TYPE *,'OUTPUT CONTROL ON SCREEN ? Y/N'
C READ (*,14) CHAR
ACCEPT 14, CHAR
14 FORMAT(A1)
CALL LOGICAL_C_IN (RET_STAT,L_SCREEN,CHAR)
IF (RET_STAT .GT. 0) CALL RETSTAT (RET_STAT,'LOGICAL_C_IN')
FIH_SWITCH=.FALSE.
FUNC='NEW'
UNIT_IN=0
VALUE_CNT=4096
EOF=.FALSE.
C TYPE *,'L_SCREEN ',L_SCREEN
C TYPE *,'EOF ',EOF
C
C***** OPEN THE FILE.
C
CALL DISK_HEAD_WRITE(FUNC,UNIT_IN,FILNAM,FILE_ID,DATA_KIND,
1 FIH_SWITCH,X_SIZE,Y_SIZE,VALUE_CNT,
2 DEPTH_BEG,DEPTH_INT,DEPTH_END,FB_DATA_SCR)
C
C*******READ DATA AND WRITE DTV DATA BLOCK
C
C OPEN (UNIT=37,FILE=DATAFILNAM,
C 1 STATUS='OLD',
C 1 DEFAULTFILE='DTV$DATA:')
OPEN (UNIT=37,FILE='DTV$DATA:'//DATAFILNAM,
1 STATUS='OLD')
IF (L_SCREEN) TYPE *,' ...READING ',DATAFILNAM,' UNTIL EOF ....'
MPS = 0
DO WHILE (.NOT. EOF)
I = 0
J = 1
DO WHILE (I .LT. 4096)
J = 1
DO WHILE (J .LE. INC)
IF (.NOT. EOF) THEN
READ (37,*,IOSTAT=EA_STATUS) FB_DATA_SCR(J+I)
IF (EA_STATUS .LT. 0) EOF = .TRUE.
IF (EOF) FB_DATA_SCR(J+I) = 0.0
ELSE
FB_DATA_SCR(J+I) = 0.0
MPS = MPS+1
END IF
IF (L_SCREEN)
1 TYPE *,'FB_DATA_SCR(',J+I,')',FB_DATA_SCR(J+I)
J = J + 1
END DO !J
DO WHILE (J .LE. Y_SIZE)
FB_DATA_SCR(J+I) = 0.0
IF (L_SCREEN)
1 TYPE *,'FB_DATA_SCR(',J+I,')',FB_DATA_SCR(J+I)
J = J + 1
END DO !J
I = I + Y_SIZE
END DO !WHILE I
C
C***** WRITE INTO FILE
C
FUNC = 'WRITE'
CALL DISK_HEAD_WRITE(FUNC,UNIT_IN,FILNAM,FILE_ID,DATA_KIND,
1 FIH_SWITCH,X_SIZE,Y_SIZE,VALUE_CNT,
2 DEPTH_BEG,DEPTH_INT,DEPTH_END,FB_DATA_SCR)
END DO !WHILE .NOT. EOF
CLOSE (UNIT=37,STATUS='KEEP')
C
C****** CLOSE THE DATA FILE.
C
FUNC='CLOSE'
DEPTH_END = DEPTH_BEG + MPS/3
TYPE *,DEPTH_BEG,DEPTH_END
CALL DISK_HEAD_WRITE(FUNC,UNIT_IN,FILNAM,FILE_ID,DATA_KIND,
1 FIH_SWITCH,X_SIZE,Y_SIZE,VALUE_CNT,
2 DEPTH_BEG,DEPTH_INT,DEPTH_END,FB_DATA_SCR)
STOP
END
PROGRAM ZEDA_C
C DIESES PROGRAMM ERMOEGLICHT DIE UMWANDLUNG VON ZAHLEN DES MULTISHOT-INSTRUMENTS
C (TEUFE,AZIMUT,NEIGUNG) ODER BELIEBIGER ANDERER INS DR-DECL-FORMAT.
C ACHTUNG: GEAENDERTES DSKHEADWRT-PROGRAM
IMPLICIT NONE
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '[PLESSMANN.TEST.COWED]DR_DECL.FOR'
REAL FB_DATA_SCR(4096), !DATAFILEBLOCK ,WHICH CONTAIN ONLY 4096
C ! DATA IN STANDARD DTV-FORMAT.
1 DEPTH_BEG,
2 DEPTH_END,
3 DEPTH_INT
INTEGER VALUE_CNT, !THE NUMBER OF DATA IN ONE BLOCK,(IN THIS
!PROGRAM THERE IS 4096 DATA).
1 DATA_KIND, !THE KIND OF DATA ,(IN THEIS PROGRAM ONLY
!THE AMPLITUDES ARE REPRESENTED).
1 FILE_ID, !THE MANNER OF DATARECORD
1 UNIT_IN, !INPUTUNITNUMBER,(IN THIS PROGRAM IT HAS
!THE VALUE "0").
1 I,
1 IOERR,
1 EA_STATUS,
1 RET_STAT,
1 MPS, !COUNTS MEASURE-POINTS
1 ROW,
1 BLOCK_COUNT !COUNTS OUTPUT_BLOCKS
INTEGER*2 X_SIZE, !THE NUMBER OF DATA IN ONE REVOLUTION.
1 Y_SIZE, !THE NUMBER OF REVOLUTIONS IN ONE DATA-
C !BLOCK.
2 INC !INCREMENT OF THE DATA INPUT FILE
LOGICAL FIH_SWITCH, !IT HAS ALWAYS THE LOGICAL VALUE"FALSE"
2 EOF,
3 L_EXIST,
4 L_FR,
5 L_CALI
CHARACTER *12 FUNC !IT HAS THREE FUNCTIONS,"OPEN" THE FILE,
!"WRITE"THE FILE,AND "CLOSE"THE FILE.
CHARACTER*60 FILNAM, !THE NAME OF THE OUTPUTFILE.
1 DATAFILNAM,
1 SITE_FILE_NAME,
1 CAL_FILE_NAME,
1 CALDIR,
1 OUTDIR,
1 INDIR
CHARACTER*3 TOOLTYPE
CHARACTER*1 CHAR
CHARACTER*(FSH$FHEXE_L) SE_FHEXE !NAME OF THE EXECUTIVE
CHARACTER*(FSH$FHMOD_L) SE_FHMOD !NAME OF EXECUTED MODULE
INTEGER*2
2 OFFSET_IN(4096), !OFFSET(S) INPUT FILE(S)
2 OFFSET_OUT(4096) !OFFSET(S) OUTPUT FILE(S)
COMMON /OFFSETS/ OFFSET_IN,OFFSET_OUT
C BEGIN:
C LESE PARAMETER_FILE EIN:
ACCEPT 13, TOOLTYPE
ACCEPT 13, CALDIR
ACCEPT 13, SITE_FILE_NAME
ACCEPT 13, OUTDIR
ACCEPT 13, FILNAM
ACCEPT 13, INDIR
ACCEPT 13, DATAFILNAM
ACCEPT 13, SE_FHEXE
13 FORMAT(A60)
DECODE (3,'(F3.1)',TOOLTYPE,ERR=99,IOSTAT=IOERR) TYPE_OF_TOOL
99 CONTINUE
IF (IOERR .NE. 0) THEN
TYPE *,'ERROR-----< DECODE , IOSTAT=',IOERR,' TOOLTYPE=',TOOLTYPE
GOTO 9999
END IF
TYPE *,' '
TYPE *,' ------'
TYPE *,' ZEDA_C'
TYPE *,' ------'
TYPE *,' '
TYPE *,'THIS PROGRAM TRANSVERS DIRECTIONAL SURVEY DATA TO DTV-FORMAT'
TYPE *,'THE INPUT DATA FILE HAVE TO BE =< SEQUENTIAL, '
TYPE *,' =< UNFORMATTED,'
TYPE *,' =< CONTAIN AN EOF MARK '
TYPE *,' '
TYPE *,'RUNNING... '
OFFSET_IN(3) = P_TIME
OFFSET_OUT(3) = P_TIME
L_FR = .TRUE.
Y_SIZE = DR$Y_SIZE
X_SIZE = 4096/Y_SIZE
DATA_KIND = 12
FILE_ID = 12
FILNAM = FILNAM//'.DTV'
INC = 3 !VALUES PER DEPTH
C >SITE- AND TOOL-PARAMETERS AVAILABLE ??<
SITE_FILE_NAME =
1CALDIR(1:(INDEX(CALDIR,' ')-1))//':'//SITE_FILE_NAME
INQUIRE (FILE=SITE_FILE_NAME,EXIST=L_EXIST)
IF (L_EXIST) THEN
CALL EXT_CAL_FILE_NAME
1 (RET_STAT,TYPE_OF_TOOL,CAL_FILE_NAME)
IF (RET_STAT .EQ. 0) L_CALI = .TRUE.
CAL_FILE_NAME =
1 CALDIR(1:(INDEX(CALDIR,' ')-1))//':'//CAL_FILE_NAME
END IF
IF (.NOT. L_CALI)
1 WRITE(*,*)
1 (' **********!NO PARAMETERS OF SITE- AND/OR ',
1 'CALIBRATION-FILE AVAILABLE !*********',I=1,10)
FIH_SWITCH=.FALSE.
FUNC='NEW'
UNIT_IN=0
VALUE_CNT=4096
EOF=.FALSE.
C
C***** OPEN THE FILE.
C
BLOCK_COUNT = 1
CALL DISK_HEAD_WRITE(FUNC,UNIT_IN,FILNAM,FILE_ID,DATA_KIND,
1 FIH_SWITCH,X_SIZE,Y_SIZE,VALUE_CNT,
2 DEPTH_BEG,DEPTH_INT,DEPTH_END,FB_DATA_SCR)
C
C*******READ DATA AND WRITE DTV DATA BLOCK
C
OPEN (UNIT=37,FILE='DTV$DATA:'//DATAFILNAM,
1 STATUS='OLD')
MPS = 1
DO WHILE (.NOT. EOF)
ROW = 1
DO WHILE (ROW .LE. DR$X_SIZE)
IF (.NOT. EOF) THEN
READ (37,*,IOSTAT=EA_STATUS,END=999) DEPTH
FB_DATA_SCR((ROW-1)*DR$Y_SIZE+P_M_DEPTH) = DEPTH
D TYPE *,'DEPTH : ',FB_DATA_SCR((ROW-1)*DR$Y_SIZE+P_M_DEPTH)
IF (L_FR) THEN
DEPTH_BEG=FB_DATA_SCR(P_M_DEPTH)
DEPTH_END=DEPTH_BEG
L_FR = .FALSE.
ELSE
C >RECHNE MITTLERES TEUFENINTERVAL AUS<
DEPTH_INT=(DEPTH_INT*(FLOAT(MPS)-1) +
1 DEPTH_END-FB_DATA_SCR((ROW-1)*DR$Y_SIZE+P_M_DEPTH))/FLOAT(MPS)
DEPTH_END=FB_DATA_SCR((ROW-1)*DR$Y_SIZE+P_M_DEPTH)
END IF
READ (37,*,IOSTAT=EA_STATUS,END=999)
1 FB_DATA_SCR((ROW-1)*DR$Y_SIZE+P_MEAS_DIP)
READ (37,*,IOSTAT=EA_STATUS,END=999)
1 FB_DATA_SCR((ROW-1)*DR$Y_SIZE+P_MEAS_AZI)
IF (EA_STATUS .LT. 0) EOF = .TRUE.
MPS = MPS+1
FB_DATA_SCR((ROW-1)*DR$Y_SIZE+P_TYPE_OF_TOOL) = TYPE_OF_TOOL
C >SETZE WEITERE VARIABLEN<
CALL SET_VARN_ERR
1 (RET_STAT,CAL_FILE_NAME,SITE_FILE_NAME,
1 FB_DATA_SCR,
1 ROW,ROW,DR$Y_SIZE,DR$Y_SIZE)
999 CONTINUE
IF (EA_STATUS .NE. 0) EOF = .TRUE.
IF (EA_STATUS .NE. 0) ROW = ROW-1
ELSE
DO I=1,DR$Y_SIZE
FB_DATA_SCR((ROW-1)*DR$Y_SIZE+I)=0.
END DO
END IF
ROW=ROW+1
END DO !WHILE
C
C***** WRITE INTO FILE
C
FUNC = 'WRITE'
BLOCK_COUNT = BLOCK_COUNT + 1
CALL DISK_HEAD_WRITE(FUNC,UNIT_IN,FILNAM,FILE_ID,DATA_KIND,
1 FIH_SWITCH,X_SIZE,Y_SIZE,VALUE_CNT,
2 DEPTH_BEG,DEPTH_INT,DEPTH_END,FB_DATA_SCR)
END DO !WHILE .NOT. EOF
C >CLOSE INPUT-FILE<
CLOSE (UNIT=37,STATUS='KEEP')
C****** CLOSE THE DATA FILE.
FUNC='CLOSE'
TYPE *,'DEPTH_BEG,DEPTH_END,DEPTH_INT:'
TYPE *,DEPTH_BEG,DEPTH_END,DEPTH_INT
CALL DISK_HEAD_WRITE(FUNC,UNIT_IN,FILNAM,FILE_ID,DATA_KIND,
1 FIH_SWITCH,X_SIZE,Y_SIZE,VALUE_CNT,
2 DEPTH_BEG,DEPTH_INT,DEPTH_END,FB_DATA_SCR)
TYPE *,' '
C...SCHREIBE IN FILE HISTORY SEGMENT:
CALL DATV_OPEN (37,FILNAM,'OLD',RET_STAT)
CALL DATV_RDWC (RET_STAT,37,1,I,I)
SE_FHMOD ='ZEDA_C'
CALL LOG_MODULEX (37,SE_FHEXE,SE_FHMOD,2,BLOCK_COUNT)
CLOSE (37,STATUS='KEEP')
9999 STOP
END
CB650