C*****************************************************************************C
C C
C SUBROUTINE M O D _ S N O P C
C C
C*****************************************************************************C
SUBROUTINE MOD_SNOP (RET_STAT)
IMPLICIT NONE
C_DESCRIPTION
C This subroutine smooths the orientated televiewer scanning lines by
C reorientation with Smoothed NOrth Pointer trace .
C Author: Jochen Plessmann
C_PARAMETER
C RET_STAT - Return status of this module (I4 output)
C 2221 --> DATA IS ALREADY PROCESSED WITH AN OLD
C INCORRECT VERSION OF DTVSYSTEM (BEFORE
C 7-JAN-1988). IT IS ASSUMED THAT THE FBH
C IS NOT CORRECT. --->NO PROCESSING POSSIBLE !
C 2222 --> GLIDING AVERAGE-WINDOW .LT. 1.
C 2223 --> BUFFER-SIZE TOO SMALL
C INPUT PARAMETERS:
C 3. number of real-parameters
C 0. number of character-parameters
C 16. gliding average window
C 0. mimimum northpointer value
C 127. maximum northpointer value
C UPD:25.6.88 BY JOCHEN PLESSMANN : Introduced MINOVA and MANOVA.
C The reason: MInimum NOrthpointer VAlue of the wbk-bhtv is 0. If a
C northpointer of an other tool starts at a different level you have
C to add MINOVA to MAXI (MAXI is the range from a single turn).
C_INCLUSIONS
INCLUDE '(BHT_DECL)'
INCLUDE '(FSH_DECL)'
INCLUDE '(FBH_DECL)'
INCLUDE '(LOC_FSH)'
INCLUDE '(COM_DKCB)'
INCLUDE '(COM_FACB)'
INCLUDE '(COM_FBLK)'
INCLUDE '(COM_ISCB)'
INCLUDE '(COM_PAPO)'
INCLUDE '(COM_POOL)'
INCLUDE '(COM_WDCB)'
C_VARIABLES
INTEGER
2 ACT_FBLK_NO, ! actual fblk in fb_data
2 AV_DIFF, ! difference between smoothed and
! original north-pointer
2 B_NEXT, ! forward reference to next fileblock
2 COL_CNT, ! number of coloumns in the image
2 COL_IND, ! coloumn index
2 EXTENSION_REFERENCE,
! ask joachim or stefan
2 F_NEXT, ! backward reference to previous fblk
2 I,J,K,L, ! loop counter
2 IBEG, ! image begin pointer
2 LBN_IN_POOL, ! number of dtv-blocks in pool
2 MOD_RET_STAT, ! saves return status of modul
2 NO_VAL, ! number of values to process
2 OFFSET, !
2 P_DKC, ! pointer tp data-kind-control-block
2 P_END, ! pointer to window end field
2 P_EXT, ! pointer to (absolut)last window field
2 P_PC, ! pointer to character parameters
2 P_PR, ! pointer to real parameters
2 RET_STAT, ! parameter
2 ROW_IND, ! row index
2 ROW_CNT, ! number of rows in the image
2 START, ! used to restore data
2 STOP, ! used to restore data
2 UNIT_NO_I4 ! unit number of opened dtv-file
INTEGER*2 ACTUAL_NP_I2
REAL ACTUAL_DEPTH,
1 OLD_ACTUAL_DEPTH,! used to locale incorrect fbh
1 ACTUAL_NP,
1 BUFFER(256), ! stores scanning line while shifting
1 DIFF,
2 GA_WINDOW, ! gliding average window
1 MANOVA, ! maximum northpointer value
1 MAXI, ! maximum input for northpointer, 0 to
! maxi-1 represents the angles from 0 to
! 360 degrees. the resolution of angle
! is 360/number of samples per scan line
1 MAXI2, ! INT(MAXI/2.)
1 MEMO, ! last north-pointer value
1 MINOVA, ! minimum northpointer value
1 NP_AV,
1 PNP_AV, ! NP_AV shifted by 128 to positive value
1 POS(3), ! positions of desired traceplot
2 U ! counts the turns of the tool
! (german:Umdrehungen)
CHARACTER*1 FIRSTRUN !
LOGICAL L_WINDOW !.true. if number of samples are .ge.
!average_window
C_END_DECLARATION
IF (FIRSTRUN .NE. 'N') THEN
C -----------------------------------------------------------------
C Get control variables from the window control block
C -----------------------------------------------------------------
IBEG = WIND_CTRB (W_BEG,WS_NO) + WIND_CTRB(W_IBG,WS_NO)
P_END = WIND_CTRB (W_END,WS_NO)
P_EXT = WIND_CTRB (W_EXT,WS_NO)
P_PR = WIND_CTRB (W_PPR,WS_NO)
P_PC = WIND_CTRB (W_PPC,WS_NO)
P_DKC = WIND_CTRB (W_DKC,WS_NO)
ROW_CNT = WIND_CTRB (W_1MS,WS_NO)
COL_CNT = WIND_CTRB (W_2MS,WS_NO)
NO_VAL = COL_CNT * ROW_CNT
IF (COL_CNT .GT. 256) THEN
CALL LIB$SET_CURSOR (15,5)
PAUSE '--> SORRY Y-SIZE IS TOO LARGE, CHANGE BUFFER-SIZE IN PROGRAM !'
RET_STAT = 2223
RETURN
END IF
C ----------------------------------
C Get the values from parameter file
C ----------------------------------
GA_WINDOW = PAR_POOLR (P_PR)
MINOVA = PAR_POOLR(P_PR + 1) ! UPD:25.6.88
MANOVA = PAR_POOLR(P_PR + 2) ! UPD:25.6.88
MAXI = PAR_POOLR(P_PR + 2) - PAR_POOLR(P_PR + 1) + 1
MAXI2 = FLOAT(INT(MAXI/2.))
IF (GA_WINDOW .LT. 1.) THEN
CALL LIB$SET_CURSOR (15,5)
PAUSE '--> GLIDING AVERAGE WINDOW .LT. 1. !'
RET_STAT = 2222
RETURN
END IF
C -----------------------------------------------------------------
C Get control variable from the file access control block
C -----------------------------------------------------------------
UNIT_NO_I4 = FACC_CTRB (1,WS_NO)
LBN_IN_POOL = FACC_CTRB (3,WS_NO) !LAST BLOCK NUMBER
C --------------------
C Operation possible ?
C --------------------
J = 1
CALL DATV_RDWC (RET_STAT,UNIT_NO_I4,INSQ_CTRB(1),B_NEXT,F_NEXT)
IF (RET_STAT.NE.0) CALL RETSTAT(RET_STAT,'DATV_RDWC')
IF (RET_STAT .EQ. 0)
1CALL FBHDT_SEG ('READ',RET_STAT,EXTENSION_REFERENCE,
1J,OLD_ACTUAL_DEPTH,ACTUAL_NP_I2)
CALL DATV_RDWC (RET_STAT,UNIT_NO_I4,INSQ_CTRB(2),B_NEXT,F_NEXT)
IF (RET_STAT.NE.0) CALL RETSTAT(RET_STAT,'DATV_RDWC')
IF (RET_STAT .EQ. 0)
1CALL FBHDT_SEG ('READ',RET_STAT,EXTENSION_REFERENCE,
1J,ACTUAL_DEPTH,ACTUAL_NP_I2)
IF (OLD_ACTUAL_DEPTH .EQ. ACTUAL_DEPTH) THEN
CALL LIB$SET_CURSOR (15,5)
WRITE (*,*)
1 'DATA ALREADY PROCESSED WITH AN INCORRECT VERSION OF DTVSYSTEM -',
2 'OR DATA IS NOT RESAMPLED . SORRY, NO PROCESSING POSSIBLE !'
RET_STAT = 2221
CALL RETSTAT (RET_STAT,' DTVMODUL SNOP')
RETURN
END IF
MOD_RET_STAT = RET_STAT
FIRSTRUN= 'N'
END IF !FIRSTRUN
C ---------------------
C Perform the operation
C ---------------------
IF (MOD_RET_STAT .EQ. 0) THEN
ROW_IND = 0
I = 1
ACT_FBLK_NO = INSQ_CTRB(I)
DO WHILE (ACT_FBLK_NO .NE. 0)
CALL DATV_RDWC (RET_STAT,UNIT_NO_I4,ACT_FBLK_NO,B_NEXT,F_NEXT)
IF (RET_STAT.NE.0) CALL RETSTAT(RET_STAT,'DATV_RDWC')
J = 1
DO WHILE (RET_STAT .EQ. 0)
CALL FBHDT_SEG ('READ',RET_STAT,EXTENSION_REFERENCE,
1 J,ACTUAL_DEPTH,ACTUAL_NP_I2)
IF (RET_STAT .EQ. 0) THEN
ACTUAL_NP = FLOATI (ACTUAL_NP_I2)
ROW_IND = ROW_IND + 1
IF (.NOT.L_WINDOW) THEN
MEMO = ACTUAL_NP
C NP_AV = MEMO
IF (J .EQ. 1) NP_AV = MEMO
IF (J .NE. 1) NP_AV = (NP_AV*FLOAT(J) + MEMO) / FLOAT(J+1)
J = J + 1
IF (J .EQ. NINT(GA_WINDOW)) L_WINDOW = .TRUE.
ELSE
DIFF = ACTUAL_NP - MEMO
IF (DIFF .LT. (-MAXI2) .AND.
1 MEMO .GT. MAXI2 .AND.
2 ACTUAL_NP .LT. MAXI2) U = U + 1.
IF (DIFF .GT. MAXI2 .AND.
1 MEMO .LT. MAXI2 .AND.
2 ACTUAL_NP .GT. MAXI2) U = U - 1.
J = J + 1
! UPD:25.6.88
NP_AV = NP_AV+((ACTUAL_NP + U*(MAXI+MINOVA))-NP_AV)/GA_WINDOW
! UPD:25.6.88
MEMO = ACTUAL_NP
END IF
PNP_AV = NP_AV
DO WHILE (PNP_AV .LT. 0.)
PNP_AV = PNP_AV + MAXI
END DO !WHILE
! UPD:25.6.88
AV_DIFF = MOD(NINT(PNP_AV),NINT(MAXI+MINOVA)) - NINT(ACTUAL_NP)
! UPD:25.6.88
IF (AV_DIFF .NE. 0) THEN ! shift scan-line
OFFSET = IBEG-1 + COL_CNT * (ROW_IND - 1)
DO K = 1 , COL_CNT
BUFFER (K) = POOL_R4(OFFSET + K)
END DO !K
START = AV_DIFF
IF (START .LT. 0) START = START + COL_CNT
START = START + 1
L = 1
DO K = START , COL_CNT
POOL_R4(OFFSET + L) = BUFFER (K)
L = L + 1
END DO !K
STOP = START - 1
DO K = 1 , STOP
POOL_R4(OFFSET + L) = BUFFER (K)
L = L + 1
END DO !K
END IF
END IF !RET_STAT .EQ.0
END DO !WHILE
RET_STAT = 0
I = I + 1
ACT_FBLK_NO = INSQ_CTRB(I)
END DO !WHILE
END IF !MOD_RET_STAT .EQ. 0
RETURN
END
C*****************************************************************************C
C C
C SUBROUTINE M O D _ S P I K E 1 C
C C
C*****************************************************************************C
SUBROUTINE MOD_SPIKE1 (RET_STAT)
IMPLICIT NONE
C_DESCRIPTION
C This subroutine eliminates spikes in data.
C This programsection controls the spike reduction subprogram spike
c the original algorithm is used in prespike, used for "deza-files".
c jp nov 1987
C Author: Jochen Plessmann
C_PARAMETER
C RET_STAT - Return status of this module (I4 output)
C - 2432 --> WRONG POINTER TO DESIRED VALUE
C For Example: INPUT PARAMETERS:
C 5. number of real-parameters
C 0. number of character-parameters
C 13. pointer to value (1. up to df_ys)
C 1. function of process
C 10. maximum spike length
C 1050. start value
C 100. maximum deviation
C_INCLUSIONS
INCLUDE '(BHT_DECL)'
INCLUDE '(COM_DKCB)'
INCLUDE '(COM_FACB)'
INCLUDE '(COM_ISCB)'
INCLUDE '(COM_PAPO)'
INCLUDE '(COM_POOL)'
INCLUDE '(COM_WDCB)'
C_VARIABLES
INTEGER
2 COL_CNT, ! number of coloumns in the image
2 COL_IND, ! coloumn index
2 DKI, ! selected data_kind
2 DTY, ! type of pool-data (I4,R4,C8)
2 IBEG, ! image begin pointer
2 LBN_IN_POOL, ! number of dtv-blocks in pool
2 NO_VAL, ! number of values to process
2 OFFSET, !
2 P_END, ! pointer to window end field
2 P_EXT, ! pointer to (absolut)last window field
2 P_PR, ! pointer to real parameters
2 P_VALUE, ! pointer to process value
2 RET_STAT, ! parameter
2 ROW_IND, ! row index
2 ROW_CNT ! number of rows in the image
REAL
1 VALUE ! actual processing value
CHARACTER*1 FIRSTRUN !
INTEGER
8 FUNC, !function of spike reduction
2 MAX_SP_LE, !maximum length of spike,see subr. spike
3 MEMO_COUNT
REAL MEMO(0:10), !see subr. spike !!
1 R_FUNC,
1 R_MAX_SP_LE
REAL
9 START_VALUE, !first value of data
1 MAX_DEV, !maximum deviation
2 VALUE actual processed value
LOGICAL
2 L_RESTORE !.true. than restore data
C_COMMON_DECLARATION
COMMON /SP_MEM/ MEMO_COUNT,MEMO
C_END_DECLARATION
IF (FIRSTRUN .NE. 'N') THEN
C -----------------------------------------------------------------
C Get control variables from the window control block
C -----------------------------------------------------------------
IBEG = WIND_CTRB (W_BEG,WS_NO) + WIND_CTRB(W_IBG,WS_NO)
P_END = WIND_CTRB (W_END,WS_NO)
P_EXT = WIND_CTRB (W_EXT,WS_NO)
P_PR = WIND_CTRB (W_PPR,WS_NO)
ROW_CNT = WIND_CTRB (W_1MS,WS_NO)
COL_CNT = WIND_CTRB (W_2MS,WS_NO)
NO_VAL = COL_CNT * ROW_CNT
DKI = DATK_CTRB (1,WS_NO) !<>WIND_CTRB(W_DKI,WS_NO) !!
DTY = WIND_CTRB (W_DTY,WS_NO)
C ----------------------------------
C Get the values from parameter file
C ----------------------------------
P_VALUE = PAR_POOLR (P_PR)
R_FUNC = PAR_POOLR (P_PR+1)
R_MAX_SP_LE = PAR_POOLR (P_PR+2)
START_VALUE = PAR_POOLR (P_PR+3)
MAX_DEV = PAR_POOLR (P_PR+4)
FUNC = NINT (R_FUNC)
MAX_SP_LE = NINT (R_MAX_SP_LE)
C --------------------
C Operation possible ?
C --------------------
IF (P_VALUE.LT. 0. .OR. P_VALUE .GT. WIND_CTRB (W_2MS,WS_NO)) THEN
CALL LIB$SET_CURSOR (15,5)
PAUSE '--> WRONG POINTER TO DESIRED VALUE !'
RET_STAT = 2432
END IF
FIRSTRUN = 'Y'
END IF !FIRSTRUN
C ---------------------
C Perform the operation
C ---------------------
IF (RET_STAT .EQ. 0) THEN
ROW_IND = 0
OFFSET = IBEG-1 + P_VALUE + COL_CNT * ROW_IND
VALUE = POOL_R4 (OFFSET)
DO WHILE (ROW_IND .LE. ROW_CNT)
OFFSET = IBEG-1 + P_VALUE + COL_CNT * (ROW_IND)
VALUE = POOL_R4 (OFFSET)
CALL SPIKE
1 (RET_STAT,FUNC,START_VALUE,MAX_DEV,MAX_SP_LE,
2 VALUE,L_RESTORE)
IF (RET_STAT .NE. 0) TYPE*,'RET_STAT:',RET_STAT
IF (L_RESTORE) THEN
D WRITE(*,*) VALUE,MEMO(0) !Z.ZT OHNE FUNC=2
POOL_R4(OFFSET) = MEMO(0)
END IF
ROW_IND = ROW_IND + 1
END DO !WHILE
END IF !RET_STAT .EQ. 0
RETURN
END
C********
SUBROUTINE SPIKE
1 (RET_STAT,FUNC,START_VALUE,MAX_DEV,MAX_SP_LE,VALUE,L_RESTORE)
C AT THIS TIME FUNC=2 DOESNOT WORK!!!!!!
C THIS SUBROUTINUE ELIMINATES SPIKES. SPIKES ARE DEFINED AS DIFFERENCE (MAX_DEV)
C FROM THE PRECEDING VALUE (OR START_VALUE AT THE FIRST RUN).
C YOU CAN CHOOSE - WHEN SPIKE : VALUE = PRECEDING VALUE ,FUNC=0
C VALUE = PRECEDING VALUE +- MAX_DEV ,FUNC=1
C EQUALIZE VALUES BEFORE AND AFTER SPIKE ,FUNC=2
C THE MAXIMUM SPIKE LENGTH IS MAX_SP_LE = 10 AT THIS TIME
C !!IF YOU CHANGE MAX_SP_LE TOU HAVE TO CHANGE MEMO (COMMON!) TOO!!
C IF L_RESTORE =.TRUE. THE MAINPROGRAM TAKES THE VALUES FROM COMMON BLOCK
C SP_MEM (VALUE_COUNT,VALUES(1:VALUE_COUNT))
C JP NOV '87
C.......VARIABLES
IMPLICIT NONE !!
INTEGER MAX_SP_LE, !MAXIMUM LENGTH OF SPIKE, SEE PARAMETER
1 FUNC, !SEE PROGRAM EXPLANATION
2 RET_STAT, !0 IF NO ERROR OCCURES
3 MEMO_COUNT,
4 K,
5 FR !0 WHEN FIRST RUN
REAL START_VALUE,
1 MAX_DEV, !MAX. DEVIATION OF VALUE FROM PREC. VALU
2 VALUE,
3 MEMO(0:10), !STORES VALUES IF A SPIKE OCCURES
C !MEMO(0) CONTAINS THE LAST VALUE IF
C ! L_RESTORE = .TRUE.
4 DIFF !DIFF BETWEEN VALUE AND PREC. VALUE
LOGICAL L_RESTORE, !.TRUE. IF NO SPIKE OCCURES OR MEMO FULL
C !.F. READ NEXT VALUE AND WAIT FOR RESTOR
1 L_POSDEV, !.TRUE. IF POSITIVE DIFFERENCE
2 L_DEV !.TRUE. IF SPIKE OCCURES
C SAVE FUNC,L_DEV,L_FR,MAX_SP_LE
COMMON /SP_MEM/ MEMO_COUNT,MEMO
C.......BEGIN:
IF (FR.EQ.0) THEN !FIRST RUN LEV1
FR=1
IF (MAX_DEV .LE. 0.) PAUSE
1 'ERROR:MAX_DEV.LE.0. TYPE EXIT OR CONTINUE !'
IF (MAX_SP_LE .GT. 0 .AND. FUNC .NE. 2) PAUSE
1 'ERR:MAX_SP_LE AND FUNC DOESNOT MATCH,EXIT OR CONTINUE!'
MEMO_COUNT = 0
MEMO(0) = VALUE
DO K = 1,MAX_SP_LE
MEMO (K) = 0.
END DO !K
DIFF = VALUE - START_VALUE
IF (ABS(DIFF) .GT. MAX_DEV) THEN !LEV2
L_DEV = .TRUE.
IF (L_DEV) THEN !LEV3
IF (FUNC .EQ. 0) THEN !LEV4
L_RESTORE = .TRUE.
MEMO(0) = START_VALUE
END IF !LEV4
IF (FUNC .EQ. 1) THEN !LEV5
IF (DIFF .GT. 0.) L_POSDEV = .TRUE.
IF (DIFF .LT. 0.) L_POSDEV = .FALSE.
L_RESTORE = .TRUE.
IF (L_POSDEV) THEN !LEV6
VALUE = START_VALUE + MAX_DEV
ELSE
VALUE = START_VALUE - MAX_DEV
END IF !LEV6
END IF !LEV5
IF (FUNC .EQ. 2) THEN !LEV7
L_RESTORE = .FALSE.
IF (MEMO_COUNT .LT. MAX_SP_LE) THEN !LEV8
MEMO(0) = START_VALUE
MEMO_COUNT = MEMO_COUNT + 1
IF (MEMO_COUNT .EQ. MAX_SP_LE)
1 L_RESTORE = .TRUE.
ELSE
L_RESTORE = .TRUE.
END IF !LEV8
ELSE
L_RESTORE = .TRUE.
END IF !LEV7
ELSE
L_RESTORE = .TRUE.
END IF !LEV3
ELSE
L_DEV = .FALSE.
L_RESTORE = .TRUE.
MEMO(0) = VALUE
MEMO_COUNT = 0
END IF !LEV2
ELSE !.NOT.L_FR LEV1
DIFF = VALUE - MEMO(0)
IF (ABS(DIFF) .GT. MAX_DEV) THEN !LEV2
L_DEV = .TRUE.
IF (DIFF .GT. 0.) L_POSDEV = .TRUE.
IF (DIFF .LT. 0.) L_POSDEV = .FALSE.
IF (L_DEV) THEN !LEV3
IF (FUNC .EQ. 0) THEN !LEV4
L_RESTORE = .TRUE.
MEMO_COUNT = 0
END IF !LEV4
IF (FUNC .EQ. 1) THEN !LEV5
MEMO_COUNT = 0
IF (L_POSDEV) THEN !LEV6
MEMO(0) = MEMO(0) + MAX_DEV
ELSE
MEMO(0) = MEMO(0) - MAX_DEV
END IF !LEV6
L_RESTORE = .TRUE.
END IF !LEV5
IF (FUNC .EQ. 2) THEN !LEV7
IF (MEMO_COUNT .LE. MAX_SP_LE) THEN !LEV8
MEMO_COUNT = MEMO_COUNT + 1
MEMO(MEMO_COUNT) = VALUE
IF (MEMO_COUNT.EQ.MAX_SP_LE) L_RESTORE=.TRUE.
ELSE
L_RESTORE = .TRUE.
END IF !LEV8
IF (L_RESTORE) THEN !LEV9
DIFF = (MEMO(MEMO_COUNT)-MEMO(0))/MEMO_COUNT
DO K=1,MEMO_COUNT-1
MEMO(K)=MEMO(K-1)+DIFF
END DO !K
END IF !LEV9
END IF !LEV7
END IF !LEV3
ELSE !NO MORE SPIKE LEV2
L_DEV = .FALSE.
L_RESTORE = .TRUE.
IF (FUNC .EQ. 2) THEN !RESTORE LEV10
MEMO_COUNT = MEMO_COUNT +1
MEMO (MEMO_COUNT) = VALUE
DIFF = (MEMO(MEMO_COUNT)-MEMO(0))/MEMO_COUNT
DO K=1,MEMO_COUNT-1
MEMO(K)=MEMO(K-1)+DIFF
END DO !K
ELSE
MEMO_COUNT = 0
MEMO(0) = VALUE
END IF !LEV10
END IF !LEV2
END IF !LEV1
RETURN
END