Skip to content

Bufrlib C code fix for WRFDA build with intel oneAPI compiler and a run-time segfault Fortran bugfix #1972

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
liujake merged 8 commits into from
Jan 10, 2024
Merged

Bufrlib C code fix for WRFDA build with intel oneAPI compiler and a run-time segfault Fortran bugfix #1972

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
e8c4f17
Update configure.defaults for intel oneAPI
mos3r3n Jan 5, 2024
0a96419
Update da_fill_obs_structures.inc for intel oneAPI
mos3r3n Jan 5, 2024
c2b42f4
Update preproc.sh for intel oneAPI
mos3r3n Jan 5, 2024
ddfb7e7
update configure.defaults
mos3r3n Jan 6, 2024
d8ede5c
Update configure.defaults
mos3r3n Jan 9, 2024
50500bc
Update bufrlib.h
mos3r3n Jan 9, 2024
9414cf4
Update stseq.c
mos3r3n Jan 9, 2024
6e13c2a
Update da_fill_obs_structures.inc
mos3r3n Jan 9, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
71 changes: 41 additions & 30 deletions var/da/da_obs/da_fill_obs_structures.inc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,9 +16,20 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)
real :: geometric_h, geopotential_h
integer :: i,j
logical :: outside
logical :: uvq_direct_local

if (trace_use) call da_trace_entry("da_fill_obs_structures")

!---------------------------------------------------------------------------
! Initialise uvq_direct_local
!---------------------------------------------------------------------------

if (.not. present(uvq_direct)) then
uvq_direct_local = .false.
else
uvq_direct_local = uvq_direct
end if

!---------------------------------------------------------------------------
! Initialise obs error factors (which will be overwritten in use_obs_errfac)
!---------------------------------------------------------------------------
Expand Down Expand Up @@ -147,21 +158,21 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)
if ( q_error_options == 1 ) then
! Calculate q error from rh error:

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
rh_error = iv%synop(n)%q%error ! q error is rh at this stage!
if (.not. uvq_direct_local) then
rh_error = iv%synop(n)%q%error ! q error is rh at this stage!

! if((ob % synop(n) % p > iv%ptop) .AND. &
! (ob % synop(n) % t > 100.0) .AND. &
! (ob % synop(n) % q > 0.0) .AND. &
! (iv % synop(n) % p % qc >= obs_qc_pointer) .and. &
! (iv % synop(n) % t % qc >= obs_qc_pointer) .and. &
! (iv % synop(n) % q % qc >= obs_qc_pointer)) then
call da_get_q_error(ob % synop(n) % p, &
call da_get_q_error(ob % synop(n) % p, &
ob % synop(n) % t, &
ob % synop(n) % q, &
iv % synop(n) % t % error, &
rh_error, iv % synop(n) % q % error)
if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data
if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data

! end if
end if
Expand All @@ -181,16 +192,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)

! Calculate q error from rh error:

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
rh_error = iv%metar(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % metar(n) % p % inv, &
if (.not. uvq_direct_local) then
rh_error = iv%metar(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % metar(n) % p % inv, &
ob % metar(n) % t, &
ob % metar(n) % q, &
iv % metar(n) % t % error, &
rh_error, q_error)
iv % metar(n) % q % error = q_error
if (iv%metar(n)% q % error == missing_r) &
iv%metar(n)% q % qc = missing_data
iv % metar(n) % q % error = q_error
if (iv%metar(n)% q % error == missing_r) &
iv%metar(n)% q % qc = missing_data
end if
end do
end if
Expand All @@ -207,16 +218,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)

! Calculate q error from rh error:

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
rh_error = iv%ships(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % ships(n) % p % inv, &
if (.not. uvq_direct_local) then
rh_error = iv%ships(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % ships(n) % p % inv, &
ob % ships(n) % t, &
ob % ships(n) % q, &
iv % ships(n) % t % error, &
rh_error, q_error)
iv % ships(n) % q % error = q_error
iv % ships(n) % q % error = q_error

if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data
if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data
end if
end do

Expand Down Expand Up @@ -301,7 +312,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)

! Calculate q error from rh error:

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
if (.not. uvq_direct_local) then
rh_error = iv%sound(n)%q(k)%error ! q error is rh at this stage!
call da_get_q_error(iv % sound(n) % p(k), &
ob % sound(n) % t(k), &
Expand All @@ -310,8 +321,8 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)
rh_error, q_error)

iv % sound(n) % q(k) % error = q_error
if (iv%sound(n)% q(k) % error == missing_r) &
iv%sound(n)% q(k) % qc = missing_data
if (iv%sound(n)% q(k) % error == missing_r) &
iv%sound(n)% q(k) % qc = missing_data
end if
end do
end do
Expand All @@ -327,15 +338,15 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)

! Calculate q error from rh error:

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % sonde_sfc(n) % p % inv, &
if (.not. uvq_direct_local) then
rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % sonde_sfc(n) % p % inv, &
ob % sonde_sfc(n) % t, &
ob % sonde_sfc(n) % q, &
iv % sonde_sfc(n) % t % error, &
rh_error, iv % sonde_sfc(n) % q % error)
if (iv%sonde_sfc(n)% q % error == missing_r) &
iv%sonde_sfc(n)% q % qc = missing_data
if (iv%sonde_sfc(n)% q % error == missing_r) &
iv%sonde_sfc(n)% q % qc = missing_data
end if
end do
end if
Expand All @@ -350,7 +361,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)
ob % airep(n) % t(k) = iv % airep(n) % t(k) % inv
ob % airep(n) % q(k) = iv % airep(n) % q(k) % inv

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
if (.not. uvq_direct_local) then
rh_error = iv%airep(n)%q(k)%error ! q error is rh at this stage!
call da_get_q_error(iv % airep(n) % p(k), &
ob % airep(n) % t(k), &
Expand Down Expand Up @@ -463,16 +474,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)

! Calculate q error from rh error:

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
rh_error = iv%buoy(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % buoy(n) % p % inv, &
if (.not. uvq_direct_local) then
rh_error = iv%buoy(n)%q%error ! q error is rh at this stage!
call da_get_q_error(iv % buoy(n) % p % inv, &
ob % buoy(n) % t, &
ob % buoy(n) % q, &
iv % buoy(n) % t % error, &
rh_error, q_error)
iv % buoy(n) % q % error = q_error
iv % buoy(n) % q % error = q_error

if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data
if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data
end if
end do
end if
Expand Down Expand Up @@ -555,7 +566,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct)

! Calculate q error from rh error:

if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then
if (.not. uvq_direct_local) then
rh_error = iv%airsr(n)%q(k)%error ! q error is rh at this stage!
call da_get_q_error(iv % airsr(n) % p(k), &
ob % airsr(n) % t(k), &
Expand Down
2 changes: 2 additions & 0 deletions var/external/bufr/bufrlib.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -94,6 +94,7 @@ void cwbmg( char *, f77int *, f77int * );
void elemdx( char *, f77int *, f77int );
void gets1loc( char *, f77int *, f77int *, f77int *, f77int *, f77int );
f77int ichkstr ( char *, char *, f77int *, f77int, f77int );
f77int icvidx( f77int *, f77int *, f77int * );
f77int ifxy( char *, f77int );
f77int igetntbi( f77int *, char *, f77int );
f77int igettdi( f77int * );
Expand All @@ -108,6 +109,7 @@ void numtbd( f77int *, f77int *, char *, char *, f77int *, f77int, f77int );
void pktdd( f77int *, f77int *, f77int *, f77int * );
f77int rbytes( char *, f77int *, f77int, f77int );
void restd( f77int *, f77int *, f77int *, f77int * );
void stntbi( f77int *, f77int *, char *, char *, char * );
void strnum( char *, f77int *, f77int );
void stseq( f77int *, f77int *, f77int *, char *, char *, f77int *, f77int * );
void uptdd( f77int *, f77int *, f77int *, f77int * );
Expand Down
8 changes: 4 additions & 4 deletions var/external/bufr/preproc.sh
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,14 +15,14 @@ cat > endiantest.c << ENDIANTEST
} \
printf("\n");

void fill(p, size) char *p; int size; {
void fill(char *p, int size) {
char *ab= "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
int i;

for (i=0; i<size; i++) p[i]= ab[i];
}

void endian(byte_size) int byte_size; {
void endian(int byte_size) {
int j=0;
unsigned int mask, i, c;

Expand All @@ -31,7 +31,7 @@ void endian(byte_size) int byte_size; {
Order(j);
}

int cprop() {
int cprop(void) {
/* Properties of type char */
char c;
int byte_size;
Expand All @@ -42,7 +42,7 @@ int cprop() {
return byte_size;
}

main()
int main(void)
{
int byte_size;

Expand Down
7 changes: 3 additions & 4 deletions var/external/bufr/stseq.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -85,7 +85,7 @@ void stseq( f77int *lun, f77int *irepct, f77int *idn, char nemo[8],
tab = 'D';
nd = igetntbi( lun, &tab, sizeof ( tab ) );
cadn30( idn, adn, sizeof( adn ) );
stntbi( &nd, lun, adn, nemo, cseq, sizeof( adn ), 8, 55 );
stntbi( &nd, lun, adn, nemo, cseq );

/*
** Now, go through the list of child descriptors corresponding to *idn.
Expand Down Expand Up @@ -180,8 +180,7 @@ void stseq( f77int *lun, f77int *irepct, f77int *idn, char nemo[8],
pkint = ( igettdi( lun ) - 49152 );
cadn30( &pkint, adn2, sizeof( adn2 ) );

stntbi( &nb, lun, adn2, nemo2, rpseq,
sizeof( adn2 ), 8, 55 );
stntbi( &nb, lun, adn2, nemo2, rpseq );

/* Initialize card to all blanks. */
memset( card, (int) cblk, sizeof( card ) );
Expand Down Expand Up @@ -356,7 +355,7 @@ void stseq( f77int *lun, f77int *irepct, f77int *idn, char nemo[8],
nb = igetntbi( lun, &tab, sizeof( tab ) );
cadn30( &cdesc[i], adn2, sizeof( adn2 ) );
stntbi( &nb, lun, adn2, &mstabs.cbmnem[ipt][0],
&mstabs.cbelem[ipt][0], sizeof( adn2 ), 8, 55 );
&mstabs.cbelem[ipt][0] );

/* Initialize card to all blanks. */
memset( card, (int) cblk, sizeof( card ) );
Expand Down